summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2016-01-18 10:16:35 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2016-01-18 10:16:35 (GMT)
commit7a410220dde1167eb71e19d5e53ce442fbe27cd6 (patch)
treea2b6c926293fbe54f11ed53d1d385d406abd6bd0
parent7b79011075ebaea03aecd04ccb351f56681469a4 (diff)
downloadtcl-7a410220dde1167eb71e19d5e53ce442fbe27cd6.zip
tcl-7a410220dde1167eb71e19d5e53ce442fbe27cd6.tar.gz
tcl-7a410220dde1167eb71e19d5e53ce442fbe27cd6.tar.bz2
Put the file location information that Tcl has into the disassembled code. Important for tclquadcode.
-rw-r--r--generic/tclDisassemble.c99
-rw-r--r--generic/tclInt.h3
-rw-r--r--tests/compile.test42
3 files changed, 131 insertions, 13 deletions
diff --git a/generic/tclDisassemble.c b/generic/tclDisassemble.c
index 86f0e1d..a60a58d 100644
--- a/generic/tclDisassemble.c
+++ b/generic/tclDisassemble.c
@@ -21,9 +21,13 @@
* Prototypes for procedures defined later in this file:
*/
-static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Obj *objPtr);
+static Tcl_Obj * DisassembleByteCodeAsDicts(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
static int FormatInstruction(ByteCode *codePtr,
const unsigned char *pc, Tcl_Obj *bufferObj);
+static void GetLocationInformation(Tcl_Interp *interp,
+ Proc *procPtr, Tcl_Obj **fileObjPtr,
+ int *linePtr);
static void PrintSourceToObj(Tcl_Obj *appendObj,
const char *stringPtr, int maxChars);
static void UpdateStringOfInstName(Tcl_Obj *objPtr);
@@ -48,6 +52,57 @@ static const Tcl_ObjType tclInstNameType = {
#define BYTECODE(objPtr) \
((ByteCode *) (objPtr)->internalRep.twoPtrValue.ptr1)
+/*
+ *----------------------------------------------------------------------
+ *
+ * GetLocationInformation --
+ *
+ * This procedure looks up the information about where a procedure was
+ * originally declared.
+ *
+ * Results:
+ * Writes to the variables pointed at by fileObjPtr and linePtr.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+GetLocationInformation(
+ Tcl_Interp *interp, /* Where to look up the location
+ * information. */
+ Proc *procPtr, /* What to look up the information for. */
+ Tcl_Obj **fileObjPtr, /* Where to write the information about what
+ * file the code came from. Will be written
+ * to, either with the object (assume shared!)
+ * that describes what the file was, or with
+ * NULL if the information is not
+ * available. */
+ int *linePtr) /* Where to write the information about what
+ * line number represented the start of the
+ * code in question. Will be written to,
+ * either with the line number or with -1 if
+ * the information is not available. */
+{
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hePtr;
+ CmdFrame *cfPtr;
+
+ *fileObjPtr = NULL;
+ *linePtr = -1;
+ if (iPtr != NULL && procPtr != NULL) {
+ hePtr = Tcl_FindHashEntry(iPtr->linePBodyPtr, procPtr);
+ if (hePtr != NULL && (cfPtr = Tcl_GetHashValue(hePtr)) != NULL) {
+ *linePtr = cfPtr->line[0];
+ if (cfPtr->type == TCL_LOCATION_SOURCE) {
+ *fileObjPtr = cfPtr->data.eval.path;
+ }
+ }
+ }
+}
+
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
@@ -68,10 +123,10 @@ static const Tcl_ObjType tclInstNameType = {
void
TclPrintByteCodeObj(
- Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */
+ Tcl_Interp *interp, /* Used only for getting location info. */
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr);
+ Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(interp, objPtr);
fprintf(stdout, "\n%s", TclGetString(bufPtr));
Tcl_DecrRefCount(bufPtr);
@@ -187,15 +242,16 @@ TclPrintSource(
Tcl_Obj *
TclDisassembleByteCodeObj(
+ Tcl_Interp *interp,
Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
ByteCode *codePtr = BYTECODE(objPtr);
unsigned char *codeStart, *codeLimit, *pc;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
- int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
+ int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i, line;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- Tcl_Obj *bufferObj;
+ Tcl_Obj *bufferObj, *fileObj;
char ptrBuf1[20], ptrBuf2[20];
TclNewObj(bufferObj);
@@ -220,6 +276,11 @@ TclDisassembleByteCodeObj(
Tcl_AppendToObj(bufferObj, " Source ", -1);
PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
+ GetLocationInformation(interp, codePtr->procPtr, &fileObj, &line);
+ if (line > -1 && fileObj != NULL) {
+ Tcl_AppendPrintfToObj(bufferObj, "\n File \"%s\" Line %d",
+ Tcl_GetString(fileObj), line);
+ }
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,
@@ -881,14 +942,16 @@ PrintSourceToObj(
static Tcl_Obj *
DisassembleByteCodeAsDicts(
+ Tcl_Interp *interp, /* Used for looking up the CmdFrame for the
+ * procedure, if one exists. */
Tcl_Obj *objPtr) /* The bytecode-holding value to take apart */
{
ByteCode *codePtr = BYTECODE(objPtr);
Tcl_Obj *description, *literals, *variables, *instructions, *inst;
- Tcl_Obj *aux, *exn, *commands;
+ Tcl_Obj *aux, *exn, *commands, *file;
unsigned char *pc, *opnd, *codeOffPtr, *codeLenPtr, *srcOffPtr, *srcLenPtr;
int codeOffset, codeLength, sourceOffset, sourceLength;
- int i, val;
+ int i, val, line;
/*
* Get the literals from the bytecode.
@@ -1152,6 +1215,13 @@ DisassembleByteCodeAsDicts(
#undef Decode
/*
+ * Get the source file and line number information from the CmdFrame
+ * system if it is available.
+ */
+
+ GetLocationInformation(interp, codePtr->procPtr, &file, &line);
+
+ /*
* Build the overall result.
*/
@@ -1174,6 +1244,15 @@ DisassembleByteCodeAsDicts(
Tcl_NewIntObj(codePtr->maxStackDepth));
Tcl_DictObjPut(NULL, description, Tcl_NewStringObj("exceptdepth", -1),
Tcl_NewIntObj(codePtr->maxExceptDepth));
+ if (line > -1) {
+ Tcl_DictObjPut(NULL, description,
+ Tcl_NewStringObj("initiallinenumber", -1),
+ Tcl_NewIntObj(line));
+ }
+ if (file) {
+ Tcl_DictObjPut(NULL, description,
+ Tcl_NewStringObj("sourcefile", -1), file);
+ }
return description;
}
@@ -1403,9 +1482,11 @@ Tcl_DisassembleObjCmd(
return TCL_ERROR;
}
if (PTR2INT(clientData)) {
- Tcl_SetObjResult(interp, DisassembleByteCodeAsDicts(codeObjPtr));
+ Tcl_SetObjResult(interp,
+ DisassembleByteCodeAsDicts(interp, codeObjPtr));
} else {
- Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
+ Tcl_SetObjResult(interp,
+ TclDisassembleByteCodeObj(interp, codeObjPtr));
}
return TCL_OK;
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 082fab4..9a5b4bf 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3152,7 +3152,8 @@ MODULE_SCOPE void TclFinalizeThreadStorage(void);
MODULE_SCOPE Tcl_WideInt TclpGetWideClicks(void);
MODULE_SCOPE double TclpWideClicksToNanoseconds(Tcl_WideInt clicks);
#endif
-MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Obj *objPtr);
+MODULE_SCOPE Tcl_Obj * TclDisassembleByteCodeObj(Tcl_Interp *interp,
+ Tcl_Obj *objPtr);
MODULE_SCOPE int TclZlibInit(Tcl_Interp *interp);
MODULE_SCOPE void * TclpThreadCreateKey(void);
MODULE_SCOPE void TclpThreadDeleteKey(void *keyPtr);
diff --git a/tests/compile.test b/tests/compile.test
index d4a31d4..46e678a 100644
--- a/tests/compile.test
+++ b/tests/compile.test
@@ -765,7 +765,7 @@ test compile-18.24 {disassembler - basics} -returnCodes error -body {
} -result "can't interpret \"\{\" as a lambda expression"
test compile-18.25 {disassembler - basics} -body {
dict keys [tcl::unsupported::getbytecode lambda {{} {}}]
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
test compile-18.26 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode proc
} -match glob -result {wrong # args: should be "* proc procName"}
@@ -778,7 +778,43 @@ test compile-18.28 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode proc chewonthis]
} -cleanup {
rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
+test compile-18.28.1 {disassembler - tricky bit} -setup {
+ eval [list proc chewonthis {} {}]
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename chewonthis {}
+} -result $bytecodekeys
+test compile-18.28.2 {disassembler - tricky bit} -setup {
+ eval {proc chewonthis {} {}}
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
+test compile-18.28.3 {disassembler - tricky bit} -setup {
+ proc Proc {n a b} {
+ proc $n $a $b
+ }
+ Proc chewonthis {} {}
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename Proc {}
+ rename chewonthis {}
} -result $bytecodekeys
+test compile-18.28.4 {disassembler - tricky bit} -setup {
+ proc Proc {n a b} {
+ tailcall proc $n $a $b
+ }
+ Proc chewonthis {} {}
+} -body {
+ dict keys [tcl::unsupported::getbytecode proc chewonthis]
+} -cleanup {
+ rename Proc {}
+ rename chewonthis {}
+} -result "$bytecodekeys initiallinenumber sourcefile"
test compile-18.29 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode script
} -match glob -result {wrong # args: should be "* script script"}
@@ -807,7 +843,7 @@ test compile-18.35 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode method foo bar]
} -cleanup {
foo destroy
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
test compile-18.36 {disassembler - basics} -returnCodes error -body {
tcl::unsupported::getbytecode objmethod
} -match glob -result {wrong # args: should be "* objmethod objectName methodName"}
@@ -824,7 +860,7 @@ test compile-18.39 {disassembler - basics} -setup {
dict keys [tcl::unsupported::getbytecode objmethod foo bar]
} -cleanup {
foo destroy
-} -result $bytecodekeys
+} -result "$bytecodekeys initiallinenumber sourcefile"
test compile-19.0 {Bug 3614102: reset stack housekeeping} -body {
# This will panic in a --enable-symbols=compile build, unless bug is fixed.