summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog15
-rw-r--r--generic/tclBasic.c284
-rw-r--r--generic/tclCompile.h5
-rw-r--r--generic/tclExecute.c12
-rw-r--r--tests/trace.test75
5 files changed, 114 insertions, 277 deletions
diff --git a/ChangeLog b/ChangeLog
index f1d502b..043c57f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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 69ddffb..000ee8f 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.250 2007/06/12 12:33:59 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.251 2007/06/15 19:58:13 msofer 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 d96c5f1..fc61542 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.72 2007/06/10 23:15:05 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.73 2007/06/15 19:58:13 msofer 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 0071263..80ec09b 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.293 2007/06/14 15:56:06 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.294 2007/06/15 19:58:13 msofer 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 539188e..212968a 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.53 2007/06/15 18:14:14 msofer Exp $
+# RCS: @(#) $Id: trace.test,v 1.54 2007/06/15 19:58:13 msofer 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