summaryrefslogtreecommitdiffstats
path: root/generic
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2010-11-15 21:32:30 (GMT)
committerandreas_kupries <akupries@shaw.ca>2010-11-15 21:32:30 (GMT)
commit94b169466ea295a3f47a309b1285f47958c2323e (patch)
treedfa2a2b2b39b6e11b2a3f366d93819a4227c8939 /generic
parent9544dc11316230740f6e007f3be2888590f4d688 (diff)
downloadtcl-94b169466ea295a3f47a309b1285f47958c2323e.zip
tcl-94b169466ea295a3f47a309b1285f47958c2323e.tar.gz
tcl-94b169466ea295a3f47a309b1285f47958c2323e.tar.bz2
* doc/interp.n: [3081184] TIP #378.
* doc/tclvars.n: Performance fix for TIP #280. * generic/tclBasic.c: * generic/tclExecute.c: * generic/tclInt.h: * generic/tclInterp.c: * tests/info.test: * tests/interp.test:
Diffstat (limited to 'generic')
-rw-r--r--generic/tclBasic.c13
-rw-r--r--generic/tclExecute.c14
-rw-r--r--generic/tclInt.h8
-rw-r--r--generic/tclInterp.c109
4 files changed, 132 insertions, 12 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0c57652..e686237 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.295.2.18 2010/07/25 10:13:49 nijtmans Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.295.2.19 2010/11/15 21:32:31 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -501,6 +501,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
@@ -3442,7 +3451,9 @@ int
TclInterpReady(
Tcl_Interp *interp)
{
+#if !defined(TCL_NO_STACK_CHECK)
int localInt; /* used for checking the stack */
+#endif
register Interp *iPtr = (Interp *) interp;
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index d70fcba..2f38758 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -13,7 +13,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.369.2.18 2010/10/09 16:31:28 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.369.2.19 2010/11/15 21:32:31 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -2412,14 +2412,18 @@ TclExecuteByteCode(
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();
result = TclEvalObjvInternal(interp, objc, objv,
/* call from TEBC */(char *) -1, -1, 0);
CACHE_STACK_INFO();
- TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc,
- codePtr, pc - codePtr->codeStart);
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc,
+ codePtr, pc - codePtr->codeStart);
+ }
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
if (result == TCL_OK) {
diff --git a/generic/tclInt.h b/generic/tclInt.h
index eb88ef0..31c9628 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -13,12 +13,14 @@
* 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.362.2.14 2010/07/25 10:13:48 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.362.2.15 2010/11/15 21:32:32 andreas_kupries Exp $
*/
#ifndef _TCLINT
#define _TCLINT
+#define TCL_NO_STACK_CHECK /* DISABLE C RUNTIME STACK CHECK - Test AIX */
+
/*
* Some numerics configuration options.
*/
@@ -2032,6 +2034,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.
@@ -2047,6 +2052,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 e7ad80d..219b059 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.83.2.4 2009/12/29 13:13:18 dkf Exp $
+ * RCS: @(#) $Id: tclInterp.c,v 1.83.2.5 2010/11/15 21:32:32 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -207,6 +207,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,
@@ -558,7 +561,7 @@ Tcl_InterpObjCmd(
int index;
static const char *options[] = {
"alias", "aliases", "bgerror", "create",
- "delete", "eval", "exists", "expose",
+ "debug", "delete", "eval", "exists", "expose",
"hide", "hidden", "issafe", "invokehidden",
"limit", "marktrusted", "recursionlimit","slaves",
"share", "target", "transfer",
@@ -566,7 +569,7 @@ Tcl_InterpObjCmd(
};
enum option {
OPT_ALIAS, OPT_ALIASES, OPT_BGERROR, OPT_CREATE,
- OPT_DELETE, OPT_EVAL, OPT_EXISTS, OPT_EXPOSE,
+ 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
@@ -706,6 +709,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;
@@ -2228,12 +2248,12 @@ SlaveObjCmd(
Tcl_Interp *slaveInterp = clientData;
int index;
static const char *options[] = {
- "alias", "aliases", "bgerror", "eval",
+ "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_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
};
@@ -2280,6 +2300,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 ...?");
@@ -2443,6 +2473,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 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.