From a4f55f2e8217331b1246d87b5244116fbe7be28b Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 1 Oct 2004 12:45:17 +0000 Subject: Speed up [upvar] and [uplevel] by not forcing level references to be parsed as strings every time through. [Patch 1037357] --- ChangeLog | 6 ++ generic/tclInt.decls | 6 +- generic/tclInt.h | 3 +- generic/tclIntDecls.h | 13 ++++- generic/tclObj.c | 3 +- generic/tclProc.c | 152 +++++++++++++++++++++++++++++++++++++++++++++----- generic/tclStubInit.c | 3 +- generic/tclVar.c | 7 +-- 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 + + * 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 * 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; } -- cgit v0.12