summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2004-10-01 12:45:17 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2004-10-01 12:45:17 (GMT)
commita4f55f2e8217331b1246d87b5244116fbe7be28b (patch)
treeb1e8471c56791d7d6064499e823653970b1550a6
parent659cfd43ab1e3669896b987ce4d501df9e9b80cc (diff)
downloadtcl-a4f55f2e8217331b1246d87b5244116fbe7be28b.zip
tcl-a4f55f2e8217331b1246d87b5244116fbe7be28b.tar.gz
tcl-a4f55f2e8217331b1246d87b5244116fbe7be28b.tar.bz2
Speed up [upvar] and [uplevel] by not forcing level references to be parsed
as strings every time through. [Patch 1037357]
-rw-r--r--ChangeLog6
-rw-r--r--generic/tclInt.decls6
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclIntDecls.h13
-rw-r--r--generic/tclObj.c3
-rw-r--r--generic/tclProc.c152
-rw-r--r--generic/tclStubInit.c3
-rw-r--r--generic/tclVar.c7
8 files changed, 171 insertions, 22 deletions
diff --git a/ChangeLog b/ChangeLog
index 5db67a1..a3bdf1d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2004-10-01 Donal K. Fellows <donal.k.fellows@man.ac.uk>
+
+ * generic/tclProc.c (TclObjGetFrame, Tcl_UplevelObjCmd):
+ * generic/tclVar.c (Tcl_UpvarObjCmd): Cache stackframe level
+ references in the level object for speed.
+
2004-09-30 Don Porter <dgp@users.sourceforge.net>
* generic/tclBasic.c (Tcl_CreateInterp): Removed the flag bit value
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 32b43e0..e25d521 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -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: tclInt.decls,v 1.79 2004/09/27 16:24:24 dgp Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.80 2004/10/01 12:45:18 dkf Exp $
library tcl
@@ -801,6 +801,10 @@ declare 197 generic {
int TclCompEvalObj (Tcl_Interp *interp, Tcl_Obj *objPtr)
}
+declare 198 generic {
+ int TclObjGetFrame(Tcl_Interp *interp, Tcl_Obj *objPtr,
+ CallFrame **framePtrPtr)
+}
##############################################################################
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 05488d2..e525c52 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.178 2004/10/01 03:19:57 dgp Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.179 2004/10/01 12:45:19 dkf Exp $
*/
#ifndef _TCLINT
@@ -1662,6 +1662,7 @@ extern Tcl_ObjType tclEnsembleCmdType;
extern Tcl_ObjType tclWideIntType;
extern Tcl_ObjType tclLocalVarNameType;
extern Tcl_ObjType tclRegexpType;
+extern Tcl_ObjType tclLevelReferenceType;
/*
* Variables denoting the hash key types defined in the core.
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 6979c88..e620e94 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -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: tclIntDecls.h,v 1.69 2004/09/27 16:24:24 dgp Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.70 2004/10/01 12:45:19 dkf Exp $
*/
#ifndef _TCLINTDECLS
@@ -1013,6 +1013,12 @@ EXTERN void TclFinalizeThreadStorageDataKey _ANSI_ARGS_((
EXTERN int TclCompEvalObj _ANSI_ARGS_((Tcl_Interp * interp,
Tcl_Obj * objPtr));
#endif
+#ifndef TclObjGetFrame_TCL_DECLARED
+#define TclObjGetFrame_TCL_DECLARED
+/* 198 */
+EXTERN int TclObjGetFrame _ANSI_ARGS_((Tcl_Interp * interp,
+ Tcl_Obj * objPtr, CallFrame ** framePtrPtr));
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1231,6 +1237,7 @@ typedef struct TclIntStubs {
void (*tclFinalizeThreadStorageData) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 195 */
void (*tclFinalizeThreadStorageDataKey) _ANSI_ARGS_((Tcl_ThreadDataKey * keyPtr)); /* 196 */
int (*tclCompEvalObj) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr)); /* 197 */
+ int (*tclObjGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, CallFrame ** framePtrPtr)); /* 198 */
} TclIntStubs;
#ifdef __cplusplus
@@ -1910,6 +1917,10 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclCompEvalObj \
(tclIntStubsPtr->tclCompEvalObj) /* 197 */
#endif
+#ifndef TclObjGetFrame
+#define TclObjGetFrame \
+ (tclIntStubsPtr->tclObjGetFrame) /* 198 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 8f1fa5e..9154690 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.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: tclObj.c,v 1.70 2004/09/29 22:22:50 dkf Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.71 2004/10/01 12:45:20 dkf Exp $
*/
#include "tclInt.h"
@@ -292,6 +292,7 @@ TclInitObjSubsystem()
Tcl_RegisterObjType(&tclCmdNameType);
Tcl_RegisterObjType(&tclLocalVarNameType);
Tcl_RegisterObjType(&tclRegexpType);
+ Tcl_RegisterObjType(&tclLevelReferenceType);
#ifdef TCL_COMPILE_STATS
Tcl_MutexLock(&tclObjMutex);
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 4d9dcfd..855cd92 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.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: tclProc.c,v 1.56 2004/09/26 16:36:04 msofer Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.57 2004/10/01 12:45:20 dkf Exp $
*/
#include "tclInt.h"
@@ -41,6 +41,20 @@ Tcl_ObjType tclProcBodyType = {
ProcBodyUpdateString, /* UpdateString procedure */
ProcBodySetFromAny /* SetFromAny procedure */
};
+
+/*
+ * The [upvar]/[uplevel] level reference type. Uses the twoPtrValue
+ * field, encoding the type of level reference in ptr1 and the actual
+ * parsed out offset in ptr2.
+ *
+ * Uses the default behaviour throughout, and never disposes of the
+ * string rep; it's just a cache type.
+ */
+
+Tcl_ObjType tclLevelReferenceType = {
+ "levelReference",
+ NULL, NULL, NULL, NULL
+};
/*
*----------------------------------------------------------------------
@@ -538,9 +552,9 @@ procError:
*/
int
-TclGetFrame(interp, string, framePtrPtr)
+TclGetFrame(interp, name, framePtrPtr)
Tcl_Interp *interp; /* Interpreter in which to find frame. */
- CONST char *string; /* String describing frame. */
+ CONST char *name; /* String describing frame. */
CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
* if global frame indicated). */
{
@@ -554,18 +568,18 @@ TclGetFrame(interp, string, framePtrPtr)
result = 1;
curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
- if (*string == '#') {
- if (Tcl_GetInt(interp, string+1, &level) != TCL_OK) {
+ if (*name== '#') {
+ if (Tcl_GetInt(interp, name+1, &level) != TCL_OK) {
return -1;
}
if (level < 0) {
levelError:
- Tcl_AppendResult(interp, "bad level \"", string, "\"",
+ Tcl_AppendResult(interp, "bad level \"", name, "\"",
(char *) NULL);
return -1;
}
- } else if (isdigit(UCHAR(*string))) { /* INTL: digit */
- if (Tcl_GetInt(interp, string, &level) != TCL_OK) {
+ } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
+ if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
return -1;
}
level = curLevel - level;
@@ -574,11 +588,121 @@ TclGetFrame(interp, string, framePtrPtr)
result = 0;
}
+ /* Figure out which frame to use, and return it to the caller */
+
+ if (level == 0) {
+ framePtr = NULL;
+ } else {
+ for (framePtr = iPtr->varFramePtr; framePtr != NULL;
+ framePtr = framePtr->callerVarPtr) {
+ if (framePtr->level == level) {
+ break;
+ }
+ }
+ if (framePtr == NULL) {
+ goto levelError;
+ }
+ }
+ *framePtrPtr = framePtr;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjGetFrame --
+ *
+ * Given a description of a procedure frame, such as the first
+ * argument to an "uplevel" or "upvar" command, locate the
+ * call frame for the appropriate level of procedure.
+ *
+ * Results:
+ * The return value is -1 if an error occurred in finding the frame
+ * (in this case an error message is left in the interp's result).
+ * 1 is returned if objPtr was either a number or a number preceded
+ * by "#" and it specified a valid frame. 0 is returned if objPtr
+ * isn't one of the two things above (in this case, the lookup
+ * acts as if objPtr were "1"). The variable pointed to by
+ * framePtrPtr is filled in with the address of the desired frame
+ * (unless an error occurs, in which case it isn't modified).
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjGetFrame(interp, objPtr, framePtrPtr)
+ Tcl_Interp *interp; /* Interpreter in which to find frame. */
+ Tcl_Obj *objPtr; /* Object describing frame. */
+ CallFrame **framePtrPtr; /* Store pointer to frame here (or NULL
+ * if global frame indicated). */
+{
+ register Interp *iPtr = (Interp *) interp;
+ int curLevel, level, result;
+ CallFrame *framePtr;
+ CONST char *name = TclGetString(objPtr);
+
/*
- * Figure out which frame to use, and modify the interpreter so
- * its variables come from that frame.
+ * Parse object to figure out which level number to go to.
*/
+ result = 1;
+ curLevel = (iPtr->varFramePtr == NULL) ? 0 : iPtr->varFramePtr->level;
+ if (objPtr->typePtr == &tclLevelReferenceType) {
+ if ((int) objPtr->internalRep.twoPtrValue.ptr1) {
+ level = curLevel - (int) objPtr->internalRep.twoPtrValue.ptr2;
+ } else {
+ level = (int) objPtr->internalRep.twoPtrValue.ptr2;
+ }
+ if (level < 0) {
+ goto levelError;
+ }
+ } else if (objPtr->typePtr == &tclIntType ||
+ objPtr->typePtr == &tclWideIntType) {
+ if (Tcl_GetIntFromObj(NULL, objPtr, &level) != TCL_OK || level < 0) {
+ goto levelError;
+ }
+ level = curLevel - level;
+ } else {
+ if (*name == '#') {
+ if (Tcl_GetInt(interp, name+1, &level) != TCL_OK) {
+ return -1;
+ }
+ if (level < 0) {
+ goto levelError;
+ }
+ /*
+ * Cache for future reference.
+ */
+ TclFreeIntRep(objPtr);
+ objPtr->typePtr = &tclLevelReferenceType;
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 0;
+ objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
+ } else if (isdigit(UCHAR(*name))) { /* INTL: digit */
+ if (Tcl_GetInt(interp, name, &level) != TCL_OK) {
+ return -1;
+ }
+ /*
+ * Cache for future reference.
+ */
+ TclFreeIntRep(objPtr);
+ objPtr->typePtr = &tclLevelReferenceType;
+ objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) 1;
+ objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) level;
+ level = curLevel - level;
+ } else {
+ /*
+ * Don't cache as the object *isn't* a level reference.
+ */
+ level = curLevel - 1;
+ result = 0;
+ }
+ }
+
+ /* Figure out which frame to use, and return it to the caller */
+
if (level == 0) {
framePtr = NULL;
} else {
@@ -594,6 +718,10 @@ TclGetFrame(interp, string, framePtrPtr)
}
*framePtrPtr = framePtr;
return result;
+
+levelError:
+ Tcl_AppendResult(interp, "bad level \"", name, "\"", (char *) NULL);
+ return -1;
}
/*
@@ -622,7 +750,6 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
register Interp *iPtr = (Interp *) interp;
- char *optLevel;
int result;
CallFrame *savedVarFramePtr, *framePtr;
@@ -636,8 +763,7 @@ Tcl_UplevelObjCmd(dummy, interp, objc, objv)
* Find the level to use for executing the command.
*/
- optLevel = TclGetString(objv[1]);
- result = TclGetFrame(interp, optLevel, &framePtr);
+ result = TclObjGetFrame(interp, objv[1], &framePtr);
if (result == -1) {
return TCL_ERROR;
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ea17c3c..e4a28d0 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.103 2004/09/27 16:24:26 dgp Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.104 2004/10/01 12:45:20 dkf Exp $
*/
#include "tclInt.h"
@@ -282,6 +282,7 @@ TclIntStubs tclIntStubs = {
TclFinalizeThreadStorageData, /* 195 */
TclFinalizeThreadStorageDataKey, /* 196 */
TclCompEvalObj, /* 197 */
+ TclObjGetFrame, /* 198 */
};
TclIntPlatStubs tclIntPlatStubs = {
diff --git a/generic/tclVar.c b/generic/tclVar.c
index ed6ec8d..5cef499 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -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: tclVar.c,v 1.92 2004/09/29 22:17:28 dkf Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.93 2004/10/01 12:45:20 dkf Exp $
*/
#ifdef STDC_HEADERS
@@ -3877,7 +3877,7 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv)
Tcl_Obj *CONST objv[]; /* Argument objects. */
{
CallFrame *framePtr;
- char *frameSpec, *localName;
+ char *localName;
int result;
if (objc < 3) {
@@ -3892,8 +3892,7 @@ Tcl_UpvarObjCmd(dummy, interp, objc, objv)
* linked to.
*/
- frameSpec = TclGetString(objv[1]);
- result = TclGetFrame(interp, frameSpec, &framePtr);
+ result = TclObjGetFrame(interp, objv[1], &framePtr);
if (result == -1) {
return TCL_ERROR;
}