summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c11
-rw-r--r--generic/tclExecute.c12
-rw-r--r--generic/tclInt.h6
-rw-r--r--generic/tclInterp.c125
4 files changed, 137 insertions, 17 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index fa63953..7fae8b3 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,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.468 2010/10/20 20:52:26 ferrieux Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.469 2010/11/15 21:34:54 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -596,6 +596,15 @@ Tcl_CreateInterp(void)
iPtr->resultSpace[0] = 0;
iPtr->threadId = Tcl_GetCurrentThread();
+ /* TIP #378 */
+#ifdef TCL_INTERP_DEBUG_FRAME
+ iPtr->flags |= INTERP_DEBUG_FRAME;
+#else
+ if (getenv("TCL_INTERP_DEBUG_FRAME") != NULL) {
+ iPtr->flags |= INTERP_DEBUG_FRAME;
+ }
+#endif
+
/*
* Initialise the tables for variable traces and searches *before*
* creating the global ns - so that the trace on errorInfo can be
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a8b408e..884c7d5 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.509 2010/10/20 20:52:28 ferrieux Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.510 2010/11/15 21:34:54 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -2120,7 +2120,9 @@ TEBCresume(
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn);
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+ }
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
iPtr->flags |= ERR_ALREADY_LOGGED;
codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
@@ -2797,8 +2799,10 @@ TEBCresume(
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, bcFramePtr, pc - codePtr->codeStart);
+ }
DECACHE_STACK_INFO();
diff --git a/generic/tclInt.h b/generic/tclInt.h
index c4ab6b3..218c40b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,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.485 2010/10/20 20:52:28 ferrieux Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.486 2010/11/15 21:34:54 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -2253,6 +2253,9 @@ typedef struct InterpList {
* SAFE_INTERP: Non zero means that the current interp is a safe
* interp (i.e. it has only the safe commands installed,
* less priviledge than a regular interp).
+ * INTERP_DEBUG_FRAME: Used for switching on various extra interpreter
+ * debug/info mechanisms (e.g. info frame eval/uplevel
+ * tracing) which are performance intensive.
* INTERP_TRACE_IN_PROGRESS: Non-zero means that an interp trace is currently
* active; so no further trace callbacks should be
* invoked.
@@ -2278,6 +2281,7 @@ typedef struct InterpList {
#define DELETED 1
#define ERR_ALREADY_LOGGED 4
+#define INTERP_DEBUG_FRAME 0x10
#define DONT_COMPILE_CMDS_INLINE 0x20
#define RAND_SEED_INITIALIZED 0x40
#define SAFE_INTERP 0x80
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index e22133a..6ccde87 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInterp.c,v 1.113 2010/08/22 18:53:26 nijtmans Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.114 2010/11/15 21:34:54 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -210,6 +210,9 @@ static int SlaveBgerror(Tcl_Interp *interp,
Tcl_Obj *const objv[]);
static Tcl_Interp * SlaveCreate(Tcl_Interp *interp, Tcl_Obj *pathPtr,
int safe);
+static int SlaveDebugCmd(Tcl_Interp *interp,
+ Tcl_Interp *slaveInterp,
+ int objc, Tcl_Obj *const objv[]);
static int SlaveEval(Tcl_Interp *interp, Tcl_Interp *slaveInterp,
int objc, Tcl_Obj *const objv[]);
static int SlaveExpose(Tcl_Interp *interp,
@@ -561,16 +564,18 @@ Tcl_InterpObjCmd(
int index;
static const char *const options[] = {
"alias", "aliases", "bgerror", "cancel",
- "create", "delete", "eval", "exists",
- "expose", "hide", "hidden", "issafe",
+ "create", "debug", "delete",
+ "eval", "exists", "expose",
+ "hide", "hidden", "issafe",
"invokehidden", "limit", "marktrusted", "recursionlimit",
"slaves", "share", "target", "transfer",
NULL
};
enum option {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CANCEL,
- OPT_CREATE, OPT_DELETE, OPT_EVAL, OPT_EXISTS,
- OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
+ OPT_CREATE, OPT_DEBUG, OPT_DELETE,
+ OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
+ OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
OPT_INVOKEHID, OPT_LIMIT, OPT_MARKTRUSTED,OPT_RECLIMIT,
OPT_SLAVES, OPT_SHARE, OPT_TARGET, OPT_TRANSFER
};
@@ -784,6 +789,23 @@ Tcl_InterpObjCmd(
Tcl_SetObjResult(interp, slavePtr);
return TCL_OK;
}
+ case OPT_DEBUG: {
+ /* TIP #378 */
+ Tcl_Interp *slaveInterp;
+
+ /*
+ * Currently only -frame supported, otherwise ?-option ?value??
+ */
+ if (objc < 3 || objc > 5) {
+ Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??");
+ return TCL_ERROR;
+ }
+ slaveInterp = GetInterp(interp, objv[2]);
+ if (slaveInterp == NULL) {
+ return TCL_ERROR;
+ }
+ return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3);
+ }
case OPT_DELETE: {
int i;
InterpInfo *iiPtr;
@@ -2376,14 +2398,16 @@ SlaveObjCmd(
Tcl_Interp *slaveInterp = clientData;
int index;
static const char *const options[] = {
- "alias", "aliases", "bgerror", "eval",
- "expose", "hide", "hidden", "issafe",
- "invokehidden", "limit", "marktrusted", "recursionlimit", NULL
+ "alias", "aliases", "bgerror", "debug",
+ "eval", "expose", "hide", "hidden",
+ "issafe", "invokehidden", "limit", "marktrusted",
+ "recursionlimit", NULL
};
enum options {
- OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_EVAL,
- OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN, OPT_ISSAFE,
- OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED, OPT_RECLIMIT
+ OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_DEBUG,
+ OPT_EVAL, OPT_EXPOSE, OPT_HIDE, OPT_HIDDEN,
+ OPT_ISSAFE, OPT_INVOKEHIDDEN, OPT_LIMIT, OPT_MARKTRUSTED,
+ OPT_RECLIMIT
};
if (slaveInterp == NULL) {
@@ -2428,6 +2452,16 @@ SlaveObjCmd(
return TCL_ERROR;
}
return SlaveBgerror(interp, slaveInterp, objc - 2, objv + 2);
+ case OPT_DEBUG:
+ /*
+ * TIP #378
+ * Currently only -frame supported, otherwise ?-option ?value? ...?
+ */
+ if (objc > 4) {
+ Tcl_WrongNumArgs(interp, 2, objv, "?-frame ?bool??");
+ return TCL_ERROR;
+ }
+ return SlaveDebugCmd(interp, slaveInterp, objc - 2, objv + 2);
case OPT_EVAL:
if (objc < 3) {
Tcl_WrongNumArgs(interp, 2, objv, "arg ?arg ...?");
@@ -2591,6 +2625,75 @@ SlaveObjCmdDeleteProc(
/*
*----------------------------------------------------------------------
*
+ * SlaveDebugCmd -- TIP #378
+ *
+ * Helper function to handle 'debug' command in a slave interpreter.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * May modify INTERP_DEBUG_FRAME flag in the slave.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SlaveDebugCmd(
+ Tcl_Interp *interp, /* Interp for error return. */
+ Tcl_Interp *slaveInterp, /* The slave interpreter in which command
+ * will be evaluated. */
+ int objc, /* Number of arguments. */
+ Tcl_Obj *const objv[]) /* Argument objects. */
+{
+ static const char *const debugTypes[] = {
+ "-frame", NULL
+ };
+ enum DebugTypes {
+ DEBUG_TYPE_FRAME
+ };
+ int debugType;
+ Interp *iPtr;
+ Tcl_Obj *resultPtr;
+
+ iPtr = (Interp *) slaveInterp;
+ if (objc == 0) {
+ resultPtr = Tcl_NewObj();
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewStringObj("-frame", -1));
+ Tcl_ListObjAppendElement(NULL, resultPtr,
+ Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
+ Tcl_SetObjResult(interp, resultPtr);
+ } else {
+ if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes,
+ "debug option", 0, &debugType) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ if (debugType == DEBUG_TYPE_FRAME) {
+ if (objc == 2) { /* set */
+ if (Tcl_GetBooleanFromObj(interp, objv[1], &debugType)
+ != TCL_OK) {
+ return TCL_ERROR;
+ }
+ /*
+ * Quietly ignore attempts to disable interp debugging.
+ * This is a one-way switch as frame debug info is maintained
+ * in a stack that must be consistent once turned on.
+ */
+ if (debugType) {
+ iPtr->flags |= INTERP_DEBUG_FRAME;
+ }
+ }
+ Tcl_SetObjResult(interp,
+ Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
+ }
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* SlaveEval --
*
* Helper function to evaluate a command in a slave interpreter.