diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | generic/tclBasic.c | 13 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 34 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 54 | ||||
| -rw-r--r-- | generic/tclCompCmds.c | 103 | ||||
| -rw-r--r-- | generic/tclExecute.c | 7 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | generic/tclProc.c | 33 |
8 files changed, 121 insertions, 142 deletions
@@ -1,3 +1,16 @@ +2004-10-18 Don Porter <dgp@users.sourceforge.net> + + * generic/tclBasic.c (Tcl_CreateInterp,Tcl_DeleteInterp): + * generic/tclCmdAH.c (Tcl_CatchObjCmd): + * generic/tclCmdMZ.c (TclMergeReturnOptions,TclProcessReturn): + * generic/tclCompCmds.c (TclCompileReturnCmd): + * generic/tclExecute.c (TclCompEvalObj): + * generic/tclInt.h (Interp): + * generic/tclProc.c (TclUpdateReturnInfo): + Place primary storage of the -level and -code information in private + fields of the Interp struct, rather than in a DictObj. This should + significantly improve performance of TclUpdateReturnInfo. + 2004-10-17 Miguel Sofer <msofer@users.sf.net> * generic/tclResult.c: removed unused variable [Bug 1048588]. diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 69a2453..84b934d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.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: tclBasic.c,v 1.127 2004/10/15 15:42:52 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.128 2004/10/18 21:15:34 dgp Exp $ */ #include "tclInt.h" @@ -233,13 +233,7 @@ Tcl_CreateInterp() Tcl_IncrRefCount(iPtr->returnLevelKey); iPtr->returnOptionsKey = Tcl_NewStringObj("-options",-1); Tcl_IncrRefCount(iPtr->returnOptionsKey); - iPtr->defaultReturnOpts = Tcl_NewDictObj(); - Tcl_DictObjPut(NULL, iPtr->defaultReturnOpts, - iPtr->returnCodeKey, Tcl_NewIntObj(TCL_OK)); - Tcl_DictObjPut(NULL, iPtr->defaultReturnOpts, - iPtr->returnLevelKey, Tcl_NewIntObj(1)); - Tcl_IncrRefCount(iPtr->defaultReturnOpts); - iPtr->returnOpts = iPtr->defaultReturnOpts; + iPtr->returnOpts = Tcl_NewObj(); Tcl_IncrRefCount(iPtr->returnOpts); iPtr->errorInfo = NULL; iPtr->eiVar = Tcl_NewStringObj("errorInfo", -1); @@ -247,6 +241,8 @@ Tcl_CreateInterp() iPtr->errorCode = NULL; iPtr->ecVar = Tcl_NewStringObj("errorCode", -1); Tcl_IncrRefCount(iPtr->ecVar); + iPtr->returnLevel = 0; + iPtr->returnCode = TCL_OK; iPtr->appendResult = NULL; iPtr->appendAvl = 0; @@ -994,7 +990,6 @@ DeleteInterpProc(interp) iPtr->errorInfo = NULL; } Tcl_DecrRefCount(iPtr->returnOpts); - Tcl_DecrRefCount(iPtr->defaultReturnOpts); Tcl_DecrRefCount(iPtr->returnCodeKey); Tcl_DecrRefCount(iPtr->returnErrorcodeKey); Tcl_DecrRefCount(iPtr->returnErrorinfoKey); diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c index 960b039..8d44139 100644 --- a/generic/tclCmdAH.c +++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.54 2004/10/15 04:01:28 dgp Exp $ + * RCS: @(#) $Id: tclCmdAH.c,v 1.55 2004/10/18 21:15:35 dgp Exp $ */ #include "tclInt.h" @@ -271,9 +271,13 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) if (objc == 4) { Interp *iPtr = (Interp *) interp; Tcl_Obj *options = Tcl_DuplicateObj(iPtr->returnOpts); - Tcl_Obj *value = NULL; - if (result != TCL_RETURN) { + if (result == TCL_RETURN) { + Tcl_DictObjPut(NULL, options, + iPtr->returnCodeKey, Tcl_NewIntObj(iPtr->returnCode)); + Tcl_DictObjPut(NULL, options, + iPtr->returnLevelKey, Tcl_NewIntObj(iPtr->returnLevel)); + } else { Tcl_DictObjPut(NULL, options, iPtr->returnCodeKey, Tcl_NewIntObj(result)); Tcl_DictObjPut(NULL, options, @@ -285,26 +289,12 @@ Tcl_CatchObjCmd(dummy, interp, objc, objv) * When result was an error, fill in any missing values * for -errorinfo, -errorcode, and -errorline */ - - value = NULL; - Tcl_DictObjGet(NULL, options, iPtr->returnErrorinfoKey, &value); - if (NULL == value) { - Tcl_DictObjPut(NULL, options, iPtr->returnErrorinfoKey, - iPtr->errorInfo); - } - - value = NULL; - Tcl_DictObjGet(NULL, options, iPtr->returnErrorcodeKey, &value); - if (NULL == value) { - Tcl_DictObjPut(NULL, options, iPtr->returnErrorcodeKey, - iPtr->errorCode); - } - value = NULL; - Tcl_DictObjGet(NULL, options, iPtr->returnErrorlineKey, &value); - if (NULL == value) { - Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey, + Tcl_DictObjPut(NULL, options, + iPtr->returnErrorinfoKey, iPtr->errorInfo); + Tcl_DictObjPut(NULL, options, + iPtr->returnErrorcodeKey, iPtr->errorCode); + Tcl_DictObjPut(NULL, options, iPtr->returnErrorlineKey, Tcl_NewIntObj(iPtr->errorLine)); - } } if (NULL == diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c index 3fba9fc..9a8b617 100644 --- a/generic/tclCmdMZ.c +++ b/generic/tclCmdMZ.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: tclCmdMZ.c,v 1.113 2004/10/15 21:02:35 dgp Exp $ + * RCS: @(#) $Id: tclCmdMZ.c,v 1.114 2004/10/18 21:15:35 dgp Exp $ */ #include "tclInt.h" @@ -930,6 +930,8 @@ TclProcessReturn(interp, code, level, returnOpts) } } if (level != 0) { + iPtr->returnLevel = level; + iPtr->returnCode = code; return TCL_RETURN; } return code; @@ -968,16 +970,17 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) * -level value should be written */ { Interp *iPtr = (Interp *) interp; - int code, level, size; + int code=TCL_OK; + int level = 1; Tcl_Obj *valuePtr; - Tcl_Obj *returnOpts = Tcl_DuplicateObj(iPtr->defaultReturnOpts); + Tcl_Obj *returnOpts = Tcl_NewObj(); for (; objc > 1; objv += 2, objc -= 2) { int optLen; CONST char *opt = Tcl_GetStringFromObj(objv[0], &optLen); int compareLen; - CONST char *compare = - Tcl_GetStringFromObj(iPtr->returnOptionsKey, &compareLen); + CONST char *compare = Tcl_GetStringFromObj( + iPtr->returnOptionsKey, &compareLen); if ((optLen == compareLen) && (strcmp(opt, compare) == 0)) { Tcl_DictSearch search; @@ -1016,7 +1019,8 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) /* Check for bogus -code value */ Tcl_DictObjGet(NULL, returnOpts, iPtr->returnCodeKey, &valuePtr); - if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code)) { + if ((valuePtr != NULL) + && (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &code))) { static CONST char *returnCodes[] = { "ok", "error", "return", "break", "continue", NULL }; @@ -1031,20 +1035,22 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) "continue, or an integer", (char *) NULL); goto error; } - /* Have a legal string value for a return code; convert to integer */ - Tcl_DictObjPut(NULL, returnOpts, - iPtr->returnCodeKey, Tcl_NewIntObj(code)); + Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnCodeKey); } /* Check for bogus -level value */ Tcl_DictObjGet(NULL, returnOpts, iPtr->returnLevelKey, &valuePtr); - if (TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level) || (level < 0)) { - /* Value is not a legal level */ - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, - "bad -level value: expected non-negative integer but got \"", + if (valuePtr != NULL) { + if ((TCL_ERROR == Tcl_GetIntFromObj(NULL, valuePtr, &level)) + || (level < 0)) { + /* Value is not a legal level */ + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "bad -level value: ", + "expected non-negative integer but got \"", TclGetString(valuePtr), "\"", (char *) NULL); - goto error; + goto error; + } + Tcl_DictObjRemove(NULL, returnOpts, iPtr->returnLevelKey); } /* @@ -1053,10 +1059,7 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) */ if (code == TCL_RETURN) { level++; - Tcl_DictObjPut(NULL, returnOpts, - iPtr->returnLevelKey, Tcl_NewIntObj(level)); - Tcl_DictObjPut(NULL, returnOpts, - iPtr->returnCodeKey, Tcl_NewIntObj(TCL_OK)); + code = TCL_OK; } if (codePtr != NULL) { @@ -1068,19 +1071,6 @@ TclMergeReturnOptions(interp, objc, objv, optionsPtrPtr, codePtr, levelPtr) if (optionsPtrPtr == NULL) { /* Not passing back the options (?!), so clean them up */ Tcl_DecrRefCount(returnOpts); - return TCL_OK; - } - - /* - * Check if we just have the default options. If so, use them. - * A dictionary equality test would be more robust, but seems - * tricky, to say the least. - */ - - Tcl_DictObjSize(NULL, returnOpts, &size); - if (size == 2 && code == TCL_OK && level == 1) { - Tcl_DecrRefCount(returnOpts); - *optionsPtrPtr = iPtr->defaultReturnOpts; } else { *optionsPtrPtr = returnOpts; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 99a98c0..92381a9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.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: tclCompCmds.c,v 1.58 2004/09/26 16:36:04 msofer Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.59 2004/10/18 21:15:37 dgp Exp $ */ #include "tclInt.h" @@ -2258,58 +2258,66 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) * General syntax: [return ?-option value ...? ?result?] * An even number of words means an explicit result argument is present. */ - int level = 1, code = TCL_OK, status = TCL_OK; + int level, code, status = TCL_OK; int numWords = parsePtr->numWords; int explicitResult = (0 == (numWords % 2)); int numOptionWords = numWords - 1 - explicitResult; - Interp *iPtr = (Interp *) interp; - Tcl_Obj *returnOpts = iPtr->defaultReturnOpts; + Tcl_Obj *returnOpts; Tcl_Token *wordTokenPtr = parsePtr->tokenPtr + (parsePtr->tokenPtr->numComponents + 1); +#define NUM_STATIC_OBJS 20 + int objc; + Tcl_Obj *staticObjArray[NUM_STATIC_OBJS], **objv; - if (numOptionWords > 0) { - /* - * Scan through the return options. If any are unknown at compile - * time, there is no value in bytecompiling. Save the option values - * known in an objv array for merging into a return options dictionary. - */ - int objc; - Tcl_Obj **objv = (Tcl_Obj **) - ckalloc(numOptionWords * sizeof(Tcl_Obj *)); - for (objc = 0; objc < numOptionWords; objc++) { - objv[objc] = Tcl_NewObj(); - Tcl_IncrRefCount(objv[objc]); - if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { - objc++; - status = TCL_ERROR; - goto cleanup; - } - wordTokenPtr += wordTokenPtr->numComponents + 1; - } - status = TclMergeReturnOptions(interp, objc, objv, - &returnOpts, &code, &level); - cleanup: - while (--objc >= 0) { - Tcl_DecrRefCount(objv[objc]); + if (numOptionWords > NUM_STATIC_OBJS) { + objv = (Tcl_Obj **) ckalloc(numOptionWords * sizeof(Tcl_Obj *)); + } else { + objv = staticObjArray; + } + + /* + * Scan through the return options. If any are unknown at compile + * time, there is no value in bytecompiling. Save the option values + * known in an objv array for merging into a return options dictionary. + */ + + for (objc = 0; objc < numOptionWords; objc++) { + objv[objc] = Tcl_NewObj(); + Tcl_IncrRefCount(objv[objc]); + if (!TclWordKnownAtCompileTime(wordTokenPtr, objv[objc])) { + objc++; + status = TCL_ERROR; + goto cleanup; } + wordTokenPtr += wordTokenPtr->numComponents + 1; + } + status = TclMergeReturnOptions(interp, objc, objv, + &returnOpts, &code, &level); +cleanup: + while (--objc >= 0) { + Tcl_DecrRefCount(objv[objc]); + } + if (numOptionWords > NUM_STATIC_OBJS) { ckfree((char *)objv); - if (TCL_ERROR == status) { - /* Something was bogus in the return options. Clear the - * error message, and report back to the compiler that this - * must be interpreted at runtime. */ - Tcl_ResetResult(interp); - return TCL_OUT_LINE_COMPILE; - } + } + if (TCL_ERROR == status) { + /* + * Something was bogus in the return options. Clear the + * error message, and report back to the compiler that this + * must be interpreted at runtime. + */ + Tcl_ResetResult(interp); + return TCL_OUT_LINE_COMPILE; } - /* All options are known at compile time, so we're going to - * bytecompile. Emit instructions to push the result on - * the stack */ + /* + * All options are known at compile time, so we're going to bytecompile. + * Emit instructions to push the result on the stack + */ if (explicitResult) { if (wordTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - /* Explicit result is a simple word, so we can compile quickly to - * a simple push */ + /* Simple word: compile quickly to a simple push */ TclEmitPush(TclRegisterNewLiteral(envPtr, wordTokenPtr[1].start, wordTokenPtr[1].size), envPtr); } else { @@ -2322,13 +2330,12 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } - /* - * Check for optimization: When [return] is in a proc, and there's - * no enclosing [catch], and the default return options are in effect, - * then the INST_DONE instruction is equivalent, and considerably more - * efficient. - */ - if (returnOpts == iPtr->defaultReturnOpts) { + /* + * Check for optimization: When [return] is in a proc, and there's + * no enclosing [catch], and there are no return options, then the + * INST_DONE instruction is equivalent, and may be more efficient. + */ + if (numOptionWords == 0) { /* We have default return options... */ if (envPtr->procPtr != NULL) { /* ... and we're in a proc ... */ @@ -2345,6 +2352,7 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) } if (!enclosingCatch) { /* ... and there is no enclosing catch. */ + Tcl_DecrRefCount(returnOpts); TclEmitOpcode(INST_DONE, envPtr); return TCL_OK; } @@ -2356,6 +2364,7 @@ TclCompileReturnCmd(interp, parsePtr, envPtr) * dictionary, and emit the INST_RETURN instruction with code * and level as operands. */ + TclEmitPush(TclAddLiteralObj(envPtr, returnOpts, NULL), envPtr); TclEmitInstInt4(INST_RETURN, code, envPtr); TclEmitInt4(level, envPtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b59389b..4268a3e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.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: tclExecute.c,v 1.157 2004/10/15 04:01:29 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.158 2004/10/18 21:15:38 dgp Exp $ */ #ifdef STDC_HEADERS @@ -983,11 +983,6 @@ TclCompEvalObj(interp, objPtr) */ codePtr->refCount++; - if (iPtr->returnOpts != iPtr->defaultReturnOpts) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = iPtr->defaultReturnOpts; - Tcl_IncrRefCount(iPtr->returnOpts); - } result = TclExecuteByteCode(interp, codePtr); codePtr->refCount--; if (codePtr->refCount <= 0) { diff --git a/generic/tclInt.h b/generic/tclInt.h index f513b19..3ffaacc 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.181 2004/10/15 04:01:31 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.182 2004/10/18 21:15:41 dgp Exp $ */ #ifndef _TCLINT @@ -1222,7 +1222,7 @@ typedef struct Interp { ActiveVarTrace *activeVarTracePtr; /* First in list of active traces for * interp, or NULL if no active traces. */ - int unused2; /* No longer used (was returnCode) */ + int returnCode; /* [return -code] parameter */ char *unused3; /* No longer used (was errorInfo) */ char *unused4; /* No longer used (was errorCode) */ @@ -1322,7 +1322,6 @@ typedef struct Interp { /* Fields used to manage extensible return options (TIP 90) */ Tcl_Obj *returnOpts; /* A dictionary holding the options to the * last [return] command */ - Tcl_Obj *defaultReturnOpts; /* Default [return] options */ Tcl_Obj *returnCodeKey; /* holds "-code" */ Tcl_Obj *returnErrorcodeKey; /* holds "-errorcode" */ Tcl_Obj *returnErrorinfoKey; /* holds "-errorinfo" */ @@ -1334,6 +1333,7 @@ typedef struct Interp { Tcl_Obj *eiVar; /* cached ref to ::errorInfo variable */ Tcl_Obj *errorCode; /* errorCode value (now as a Tcl_Obj) */ Tcl_Obj *ecVar; /* cached ref to ::errorInfo variable */ + int returnLevel; /* [return -level] parameter */ /* * Resource limiting framework support (TIP#143). diff --git a/generic/tclProc.c b/generic/tclProc.c index 3756024..9ce8706 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.61 2004/10/15 21:02:36 dgp Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.62 2004/10/18 21:15:42 dgp Exp $ */ #include "tclInt.h" @@ -1430,16 +1430,15 @@ TclProcCleanupProc(procPtr) * TclUpdateReturnInfo -- * * This procedure is called when procedures return, and at other - * points where the TCL_RETURN code is used. It examines values - * stored in the iPtr->returnOpts dictionary and modifies - * the real return status accordingly. + * points where the TCL_RETURN code is used. It examines the + * returnLevel and returnCode to determine the real return status. * * Results: * The return value is the true completion code to use for - * the procedure, instead of TCL_RETURN. + * the procedure or script, instead of TCL_RETURN. * * Side effects: - * The errorInfo and errorCode fields may get set. + * None. * *---------------------------------------------------------------------- */ @@ -1449,27 +1448,15 @@ TclUpdateReturnInfo(iPtr) Interp *iPtr; /* Interpreter for which TCL_RETURN * exception is being processed. */ { - int level, code = TCL_RETURN; - Tcl_Obj *valuePtr; + int code = TCL_RETURN; - Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnLevelKey, &valuePtr); - Tcl_GetIntFromObj(NULL, valuePtr, &level); - level--; - if (level < 0) { + iPtr->returnLevel--; + if (iPtr->returnLevel < 0) { Tcl_Panic("TclUpdateReturnInfo: negative return level"); } - if (Tcl_IsShared(iPtr->returnOpts)) { - Tcl_DecrRefCount(iPtr->returnOpts); - iPtr->returnOpts = Tcl_DuplicateObj(iPtr->returnOpts); - Tcl_IncrRefCount(iPtr->returnOpts); - } - Tcl_DictObjPut(NULL, iPtr->returnOpts, - iPtr->returnLevelKey, Tcl_NewIntObj(level)); - - if (level == 0) { + if (iPtr->returnLevel == 0) { /* Now we've reached the level to return the requested -code */ - Tcl_DictObjGet(NULL, iPtr->returnOpts, iPtr->returnCodeKey, &valuePtr); - Tcl_GetIntFromObj(NULL, valuePtr, &code); + return iPtr->returnCode; } return code; } |