diff options
| -rw-r--r-- | ChangeLog | 15 | ||||
| -rw-r--r-- | generic/tclBasic.c | 284 | ||||
| -rw-r--r-- | generic/tclCompile.h | 5 | ||||
| -rw-r--r-- | generic/tclExecute.c | 12 | ||||
| -rw-r--r-- | tests/trace.test | 75 |
5 files changed, 114 insertions, 277 deletions
@@ -1,10 +1,15 @@ 2007-06-15 Miguel Sofer <msofer@users.sf.net> - * generic/trace.test: added tests 36.* for dynamic trace creation - and addition. These tests expose a change in dynamics due to a - recent round of optimisations. The "correct" behaviour is not - described in docs nor TIP 62. Currently test 36.2 fails, the opts - will be rolled back. + * generic/tclCompile.c: reverted TclEvalObjvInternal and + * generic/tclExecute.c: INST_INVOKE to essentially what they were + * generic/tclBasic.c: previous to the commit of 2007-04-03 + [Patch 1693802] and the subsequent optimisations, as they break + the new trace tests described below. + + * generic/trace.test: added tests 36 to 38 for dynamic trace + creation and addition. These tests expose a change in dynamics due + to a recent round of optimisations. The "correct" behaviour is not + described in docs nor TIP 62. 2007-06-14 Miguel Sofer <msofer@users.sf.net> diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 026dc1d..e9e164c 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.244.2.3 2007/06/12 15:56:42 dgp Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.244.2.4 2007/06/15 20:30:18 dgp Exp $ */ #include "tclInt.h" @@ -91,12 +91,6 @@ static int ExprWideFunc(ClientData clientData, Tcl_Interp *interp, static void MathFuncWrongNumArgs(Tcl_Interp* interp, int expected, int actual, Tcl_Obj *const *objv); -static int FullEvalObjvInternal(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], const char *command, - int length, int flags); -static int ProcessEvalObjvReturn(Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[], int flags, int code); - extern TclStubs tclStubs; /* @@ -3385,20 +3379,14 @@ TclInterpReady( /* *---------------------------------------------------------------------- * - * TclEvalObjvInternal, FullEvalObjvInternal, TclEvalObjvKnownCommand -- + * TclEvalObjvInternal * - * These functions evaluate a Tcl command that has already been parsed + * This function evaluates a Tcl command that has already been parsed * into words, with one Tcl_Obj holding each word. The caller is * responsible for managing the iPtr->numLevels. * - * TclEvalObjvInternal is the backend for Tcl_EvalObjv, the other two are - * separate backends for TclEvalObjvInternal: - * - FullEvalObjvInternal is the full implementation, with [unknown] and - * trace handling. - * - TclEvalObjvKnownCommand is a fast implementation for known untraced - * commands. - * The bytecode engine calls directly into both TclEvalObjvInternal and - * TclEvalObjvKnownCommand. + * TclEvalObjvInternal is the backend for Tcl_EvalObjv, the bytecode + * engine also calls it directly. * * Results: * The return value is a standard Tcl completion code such as TCL_OK or @@ -3409,18 +3397,11 @@ TclInterpReady( * Side effects: * Depends on the command. * - * Notes to maintainers: - * * This function has to be kept in sync with the shortcut version in - * TclExecuteByteCode (INST_INVOKE). - * * This function has been split in two: a full version that processes - * unknown an traced commands too, and a shorter one that handles the - * normal case. They have to be kept in sync. - * *---------------------------------------------------------------------- */ -static int -FullEvalObjvInternal( +int +TclEvalObjvInternal( Tcl_Interp *interp, /* Interpreter in which to evaluate the * command. Also used for error reporting. */ int objc, /* Number of words in command. */ @@ -3448,9 +3429,17 @@ FullEvalObjvInternal( int code = TCL_OK; int traceCode = TCL_OK; int checkTraces = 1; - int haveTraces; Namespace *savedNsPtr = NULL; Namespace *lookupNsPtr = iPtr->lookupNsPtr; + + + if (TclInterpReady(interp) == TCL_ERROR) { + return TCL_ERROR; + } + + if (objc == 0) { + return TCL_OK; + } /* * If any execution traces rename or delete the current command, we may @@ -3581,8 +3570,7 @@ FullEvalObjvInternal( * Call trace functions if needed. */ - haveTraces = (iPtr->tracePtr != NULL) || (cmdPtr->flags & CMD_HAS_EXEC_TRACES); - if (haveTraces && checkTraces) { + if (checkTraces && ((iPtr->tracePtr != NULL) || (cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { int cmdEpoch = cmdPtr->cmdEpoch; int newEpoch; @@ -3642,7 +3630,7 @@ FullEvalObjvInternal( * Call 'leave' command traces */ - if (haveTraces) { + if (((iPtr->tracePtr != NULL) || (cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { if (!(cmdPtr->flags & CMD_IS_DELETED)) { if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { traceCode = TclCheckExecutionTraces(interp, command, length, @@ -3690,206 +3678,6 @@ FullEvalObjvInternal( } return code; } - -int -TclEvalObjvKnownCommand( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ - Tcl_Obj *const objv[], /* An array of pointers to objects that are - * the words that make up the command. */ - Command *cmdPtr) /* The already determined valid command */ -{ - Interp *iPtr = (Interp *) interp; - int code = TCL_OK; - - /* - * Finally, invoke the command's Tcl_ObjCmdProc. - */ - - cmdPtr->refCount++; - iPtr->cmdCount++; - - if (!TclLimitExceeded(iPtr->limit)) { - code = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, objc, objv); - } - if (Tcl_AsyncReady()) { - code = Tcl_AsyncInvoke(interp, code); - } - if (code == TCL_OK && TclLimitReady(iPtr->limit)) { - code = Tcl_LimitCheck(interp); - } - - /* - * Decrement the reference count of cmdPtr and deallocate it if it has - * dropped to zero. - */ - - TclCleanupCommandMacro(cmdPtr); - - /* - * If the interpreter has a non-empty string result, the result object is - * either empty or stale because some function set interp->result - * directly. If so, move the string result to the result object, then - * reset the string result. - */ - - if (*(iPtr->result) != 0) { - (void) Tcl_GetObjResult(interp); - } - - return code; -} - -int -TclEvalObjvInternal( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ - Tcl_Obj *const objv[], /* An array of pointers to objects that are - * the words that make up the command. */ - const char *command, /* Points to the beginning of the string - * representation of the command; this is used - * for traces. NULL if the string - * representation of the command is unknown is - * to be generated from (objc,objv).*/ - int length, /* Number of bytes in command; if -1, all - * characters up to the first null byte are - * used. */ - int flags) /* Collection of OR-ed bits that control the - * evaluation of the script. Only - * TCL_EVAL_GLOBAL and TCL_EVAL_INVOKE are - * currently supported. */ -{ - Command *cmdPtr; - Interp *iPtr = (Interp *) interp; - CallFrame *varFramePtr = iPtr->varFramePtr; - Namespace *savedNsPtr = NULL; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } - - if (objc == 0) { - return TCL_OK; - } - - /* - * Configure evaluation context to match the requested flags. - */ - - if (flags) { - if (flags & TCL_EVAL_INVOKE) { - savedNsPtr = varFramePtr->nsPtr; - if (lookupNsPtr) { - varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; - } else { - varFramePtr->nsPtr = iPtr->globalNsPtr; - } - } else if ((flags & TCL_EVAL_GLOBAL) && (varFramePtr != iPtr->rootFramePtr)) { - /* - * Use the full version, so that this one can do optimised tail calls. - */ - - return FullEvalObjvInternal(interp, objc, objv, command, length, flags); - } - } - - /* - * Find the function to execute this command. If there isn't one, or if - * there are traces, delegate to the full version. - */ - - cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); - if (savedNsPtr) { - varFramePtr->nsPtr = savedNsPtr; - } - - if ((cmdPtr && !iPtr->tracePtr && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { - if (!(flags & TCL_EVAL_INVOKE) && - (iPtr->ensembleRewrite.sourceObjs != NULL)) { - iPtr->ensembleRewrite.sourceObjs = NULL; - } - return TclEvalObjvKnownCommand(interp, objc, objv, cmdPtr); - } else { - /* - * Need the full version: command is either unknown or traced - */ - - if (lookupNsPtr) { - iPtr->lookupNsPtr = lookupNsPtr; - } - return FullEvalObjvInternal(interp, objc, objv, command, length, flags); - } -} - -/* - *---------------------------------------------------------------------- - * - * ProcessEvalObjvReturn -- - * - * This function does special handling for non TCL_OK returns from - * Tcl_EvalObjv. - * - * Results: - * The return value is a standard Tcl completion code such as TCL_OK or - * TCL_ERROR. A result or error message is left in interp's result. - * - * Side effects: - * May alter the return code and/or generate an error log. - * - *---------------------------------------------------------------------- - */ - -static int -ProcessEvalObjvReturn( - Tcl_Interp *interp, /* Interpreter in which to evaluate the - * command. Also used for error reporting. */ - int objc, /* Number of words in command. */ - Tcl_Obj *const objv[], /* An array of pointers to objects that are - * the words that make up the command. */ - int flags, - int code) /* The return code to be processed */ -{ - Interp *iPtr = (Interp *) interp; - int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); - - /* - * If we are again at the top level, process any unusual return code - * returned by the evaluated code. - */ - - if (iPtr->numLevels == 0) { - if (code == TCL_RETURN) { - code = TclUpdateReturnInfo(iPtr); - } - if ((code != TCL_ERROR) && !allowExceptions) { - ProcessUnexpectedResult(interp, code); - code = TCL_ERROR; - } - } - - if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { - /* - * If there was an error, a command string will be needed for the - * error log: generate it now. Do not worry too much about doing - * it expensively. - */ - - Tcl_Obj *listPtr; - char *cmdString; - int cmdLen; - - listPtr = Tcl_NewListObj(objc, objv); - cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); - Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); - Tcl_DecrRefCount(listPtr); - } - - return code; -} /* *---------------------------------------------------------------------- @@ -3931,7 +3719,41 @@ Tcl_EvalObjv( if (code == TCL_OK) { return code; } else { - return ProcessEvalObjvReturn(interp, objc, objv, flags, code); + int allowExceptions = (iPtr->evalFlags & TCL_ALLOW_EXCEPTIONS); + + /* + * If we are again at the top level, process any unusual return code + * returned by the evaluated code. + */ + + if (iPtr->numLevels == 0) { + if (code == TCL_RETURN) { + code = TclUpdateReturnInfo(iPtr); + } + if ((code != TCL_ERROR) && !allowExceptions) { + ProcessUnexpectedResult(interp, code); + code = TCL_ERROR; + } + } + + if ((code == TCL_ERROR) && !(flags & TCL_EVAL_INVOKE)) { + /* + * If there was an error, a command string will be needed for the + * error log: generate it now. Do not worry too much about doing + * it expensively. + */ + + Tcl_Obj *listPtr; + char *cmdString; + int cmdLen; + + listPtr = Tcl_NewListObj(objc, objv); + cmdString = Tcl_GetStringFromObj(listPtr, &cmdLen); + Tcl_LogCommandInfo(interp, cmdString, cmdString, cmdLen); + Tcl_DecrRefCount(listPtr); + } + + return code; } } diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a5cd143..02fdc28 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -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: tclCompile.h,v 1.70.2.2 2007/06/12 15:56:42 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.70.2.3 2007/06/15 20:30:19 dgp Exp $ */ #ifndef _TCLCOMPILATION @@ -808,9 +808,6 @@ typedef struct { MODULE_SCOPE int TclEvalObjvInternal(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], CONST char *command, int length, int flags); -MODULE_SCOPE int TclEvalObjvKnownCommand(Tcl_Interp *interp, - int objc, Tcl_Obj *const objv[], - Command *cmdPtr); /* *---------------------------------------------------------------- * Procedures exported by the engine to be used by tclBasic.c diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 5de3d3a..9f8c498 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -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: tclExecute.c,v 1.285.2.3 2007/06/14 17:03:36 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.285.2.4 2007/06/15 20:30:22 dgp Exp $ */ #include "tclInt.h" @@ -1959,14 +1959,8 @@ TclExecuteByteCode( cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); if (cmdPtr && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && iPtr->tracePtr == NULL - && (!checkInterp - || (codePtr->compileEpoch == iPtr->compileEpoch))) { - /* - * No traces, the interp is ok: use the fast interface - */ - - result = TclEvalObjvKnownCommand(interp, objc, objv, cmdPtr); + && iPtr->tracePtr == NULL) { + result = TclEvalObjvInternal(interp, objc, objv, NULL, 0, 0); } else { /* * If trace procedures will be called, we need a command diff --git a/tests/trace.test b/tests/trace.test index c136f3c..6cc492e 100644 --- a/tests/trace.test +++ b/tests/trace.test @@ -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: trace.test,v 1.51.2.2 2007/06/15 19:50:43 dgp Exp $ +# RCS: @(#) $Id: trace.test,v 1.51.2.3 2007/06/15 20:30:23 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -2477,42 +2477,57 @@ proc untraced {type} { trace add execution untraced $type {traceproc tracevar} append ::tracevar - } - +proc runbase {results base} { + set tt {enter leave enterstep leavestep} + foreach n {1 2 3 4} t $tt r $results { + eval [subst $base] + } +} set base { - test trace-36.%N% {dynamic trace creation: %T%} -setup { + test trace-36.$n {dynamic trace creation: $t} -setup { set ::tracevar {} } -cleanup { unset ::tracevar - trace remove execution untraced %T% {traceproc tracevar} + trace remove execution untraced $t {traceproc tracevar} } -body { - untraced %T% + untraced $t set ::tracevar - } -result %R% + } -result {$r} } +runbase {- -* - -} $base -foreach n { - 1 2 3 4 -} t { - enter leave enterstep leavestep -} r { - - -* - - -} { - set smap [list %N% $n %T% $t %R% $r] - eval [string map $smap $base] +set base { + test trace-37.$n {dynamic trace addition: $t} -setup { + set ::tracevar {} + set ::tracevar2 {} + trace add execution untraced enter {traceproc tracevar2} + } -cleanup { + trace remove execution untraced $t {traceproc tracevar} + trace remove execution untraced enter {traceproc tracevar2} + unset ::tracevar ::tracevar2 + } -body { + untraced $t + list \$::tracevar \$::tracevar2 + } -result {$r} } +runbase {{- *} {-* *} {- *} {- *}} $base + +set base { + test trace-38.$n {dynamic trace addition: $t} -setup { + set ::tracevar {} + set ::tracevar2 {} + trace add execution untraced leave {traceproc tracevar2} + } -cleanup { + trace remove execution untraced $t {traceproc tracevar} + trace remove execution untraced leave {traceproc tracevar2} + unset ::tracevar ::tracevar2 + } -body { + untraced $t + list \$::tracevar \$::tracevar2 + } -result {$r} +} +runbase {{- *} {-* *} {- *} {- *}} $base -test trace-36.5 {dynamic trace addition} -setup { - set ::tracevar {} - set ::tracevar2 {} - trace add execution untraced leave {traceproc tracevar2} -} -cleanup { - trace remove execution untraced leave {traceproc tracevar} - trace remove execution untraced leave {traceproc tracevar2} -} -body { - untraced leave - list $::tracevar $::tracevar2 -} -result {-* *} - # Delete procedures when done, so we don't clash with other tests @@ -2520,9 +2535,13 @@ test trace-36.5 {dynamic trace addition} -setup { catch {rename foobar {}} catch {rename foo {}} catch {rename bar {}} +catch {rename untraced {}} +catch {rename traceproc {}} +catch {rename runbase {}} -# Unset the varaible when done +# Unset the variable when done catch {unset info} +catch {unset base} # cleanup ::tcltest::cleanupTests |