summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog50
-rw-r--r--generic/tclBasic.c220
-rw-r--r--generic/tclCmdAH.c43
-rw-r--r--generic/tclCmdMZ.c15
-rw-r--r--generic/tclCompile.c98
-rw-r--r--generic/tclCompile.h17
-rw-r--r--generic/tclExecute.c100
-rw-r--r--generic/tclInt.h47
-rw-r--r--tests/info.test20
9 files changed, 443 insertions, 167 deletions
diff --git a/ChangeLog b/ChangeLog
index ae48b2e..717c1d5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,53 @@
+2009-07-13 Andreas Kupries <andreask@activestate.com>
+
+ * generic/tclCompile.c (TclInitCompileEnv, EnterCmdWordIndex,
+ TclCleanupByteCode, TclCompileScript):
+ * generic/tclExecute.c (TclCompileObj, TclExecuteByteCode):
+ * tclCompile.h (ExtCmdLoc):
+ * tclInt.h (ExtIndex, CFWordBC, CmdFrame):
+ * tclBasic.c (DeleteInterpProc, TclArgumentBCEnter,
+ TclArgumentBCRelease, TclArgumentGet, SAVE_CONTEXT,
+ RESTORE_CONTEXT, NRCoroutineExitCallback, TclNRCoroutineObjCmd):
+ * generic/tclCmdAH.c (TclNRForObjCmd, TclNRForIterCallback,
+ ForNextCallback):
+ * generic/tclCmdMZ.c (TclNRWhileObjCmd):
+
+ Extended the bytecode compiler initialization to recognize the
+ compilation of whole files (NRE enabled 'source' command) and
+ switch to the counting of absolute lines in that case.
+
+ Further extended the bytecode compiler to track the start line in
+ the generated information, and modified the bytecode execution to
+ recompile an object if the location as per the calling context
+ doesn't match the location saved in the bytecode. This part could
+ be optimized more by using more memory to keep all possibilities
+ which occur around, or by just adjusting the location information
+ instead of a total recompile.
+
+ Reworked the handling of literal command arguments in bytecode to
+ be saved (compiler) and used (execution) per command (See the
+ TCL_INVOKE_STK* instructions), and not per the whole bytecode.
+ This, and the previous change remove the problems with location
+ data caused by literal sharing (across whole files, but also proc
+ bodies). Simplified the associated datastructures (ExtIndex is
+ gone, as is the function EnterCmdWordIndex).
+
+ The last change causes the hashtable 'lineLABCPtr' to be state
+ which has to be kept per coroutine, like the CmdFrame stack.
+ Reworked the coroutine support code to create, delete and switch
+ the information as needed. Further reworked the tailcall command
+ as well, it has to pop its own arguments when run in a bytecode
+ context to keep a proper stack in 'lineLABCPtr'.
+
+ Fixed the mishandling of line information in the NRE-enabled 'for'
+ and 'while' commands introduced when both were made to share their
+ iteration callbacks without taking into account that the loop body
+ is found in different words of the command. Introduced a separate
+ data structure to hold all the callback information, as we went
+ over the limit of 4 direct client-data values for NRE callbacks.
+
+ The above fixes [Bug 1605269].
+
2009-07-12 Donal K. Fellows <dkf@users.sf.net>
* generic/tclCmdMZ.c (StringIndexCmd, StringEqualCmd, StringCmpCmd):
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 264fdc8..a097976 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,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.394 2009/05/08 08:48:19 dkf Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.395 2009/07/14 16:34:08 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -1545,9 +1545,7 @@ DeleteInterpProc(
ckfree((char *) eclPtr->loc);
}
- if (eclPtr->eiloc != NULL) {
- ckfree((char *) eclPtr->eiloc);
- }
+ Tcl_DeleteHashTable (&eclPtr->litInfo);
ckfree((char *) eclPtr);
Tcl_DeleteHashEntry(hPtr);
@@ -5448,49 +5446,74 @@ TclArgumentRelease(
void
TclArgumentBCEnter(
- Tcl_Interp *interp,
- void *codePtr,
- CmdFrame *cfPtr)
+ Tcl_Interp* interp,
+ Tcl_Obj* objv[],
+ int objc,
+ void* codePtr,
+ CmdFrame* cfPtr,
+ int pc)
{
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
- (char *) codePtr);
+ Interp* iPtr = (Interp*) interp;
+ Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
if (hePtr) {
- ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
- int i;
+ ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
+ hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc);
- for (i = 0; i < eclPtr->nueiloc; i++) {
- ExtIndex *eiPtr = &eclPtr->eiloc[i];
- Tcl_Obj *obj = eiPtr->obj;
- int new;
- Tcl_HashEntry *hPtr;
- CFWordBC *cfwPtr;
+ if (hePtr) {
+ int word;
+ int cmd = (int) Tcl_GetHashValue(hePtr);
+ ECL* ePtr = &eclPtr->loc[cmd];
+ CFWordBC* lastPtr = 0;
- hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr, (char *) obj, &new);
- if (new) {
- /*
- * The word is not on the stack yet, remember the current
- * location and initialize references.
- */
+ /*
+ * A few truths ...
+ * (1) ePtr->nline == objc
+ * (2) (ePtr->line[word] < 0) => !literal, for all words
+ * (3) (word == 0) => !literal
+ *
+ * Item (2) is why we can use objv to get the literals, and do not
+ * have to save them at compile time.
+ */
- cfwPtr = (CFWordBC *) ckalloc(sizeof(CFWordBC));
- cfwPtr->framePtr = cfPtr;
- cfwPtr->eiPtr = eiPtr;
- cfwPtr->refCount = 1;
- Tcl_SetHashValue(hPtr, cfwPtr);
- } else {
- /*
- * The word is already on the stack, its current location is
- * not relevant. Just remember the reference to prevent early
- * removal.
- */
+ for (word = 1; word < objc; word++) {
+ if (ePtr->line[word] >= 0) {
+ int isnew;
+ Tcl_HashEntry* hPtr =
+ Tcl_CreateHashEntry (iPtr->lineLABCPtr,
+ (char*) objv[word], &isnew);
+ CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC));
+
+ cfwPtr->framePtr = cfPtr;
+ cfwPtr->obj = objv[word];
+ cfwPtr->pc = pc;
+ cfwPtr->word = word;
+ cfwPtr->nextPtr = lastPtr;
+ lastPtr = cfwPtr;
+
+ if (isnew) {
+ /*
+ * The word is not on the stack yet, remember the
+ * current location and initialize references.
+ */
+ cfwPtr->prevPtr = NULL;
+ } else {
+ /*
+ * The object is already on the stack, however it may
+ * have a different location now (literal sharing may
+ * map multiple location to a single Tcl_Obj*. Save
+ * the old information in the new structure.
+ */
+ cfwPtr->prevPtr = (CFWordBC*) Tcl_GetHashValue(hPtr);
+ }
- cfwPtr = Tcl_GetHashValue(hPtr);
- cfwPtr->refCount++;
- }
- }
- }
+ Tcl_SetHashValue (hPtr, cfwPtr);
+ }
+ } /* for */
+
+ cfPtr->litarg = lastPtr;
+ } /* if */
+ } /* if */
}
/*
@@ -5516,37 +5539,33 @@ TclArgumentBCEnter(
void
TclArgumentBCRelease(
Tcl_Interp *interp,
- void *codePtr)
+ CmdFrame* cfPtr)
{
- Interp *iPtr = (Interp *) interp;
- Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
- (char *) codePtr);
+ Interp* iPtr = (Interp*) interp;
+ CFWordBC* cfwPtr = (CFWordBC*) cfPtr->litarg;
- if (hePtr) {
- ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
- int i;
-
- for (i = 0; i < eclPtr->nueiloc; i++) {
- Tcl_Obj *obj = eclPtr->eiloc[i].obj;
- Tcl_HashEntry *hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr,
- (char *) obj);
- CFWordBC *cfwPtr;
-
- if (!hPtr) {
- continue;
- }
-
- cfwPtr = Tcl_GetHashValue(hPtr);
+ while (cfwPtr) {
+ CFWordBC* nextPtr = cfwPtr->nextPtr;
+ Tcl_HashEntry* hPtr =
+ Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) cfwPtr->obj);
+ CFWordBC* xPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
- cfwPtr->refCount--;
- if (cfwPtr->refCount > 0) {
- continue;
- }
+ if (xPtr != cfwPtr) {
+ Tcl_Panic ("TclArgumentBC Enter/Release Mismatch");
+ }
- ckfree((char *) cfwPtr);
+ if (cfwPtr->prevPtr) {
+ Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
+ } else {
Tcl_DeleteHashEntry(hPtr);
}
+
+ ckfree((char *) cfwPtr);
+
+ cfwPtr = nextPtr;
}
+
+ cfPtr->litarg = NULL;
}
/*
@@ -5612,13 +5631,12 @@ TclArgumentGet(
hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, (char *) obj);
if (hPtr) {
CFWordBC *cfwPtr = Tcl_GetHashValue(hPtr);
- ExtIndex *eiPtr = cfwPtr->eiPtr;
framePtr = cfwPtr->framePtr;
framePtr->data.tebc.pc = (char *) (((ByteCode *)
- framePtr->data.tebc.codePtr)->codeStart + eiPtr->pc);
+ framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc);
*cfPtrPtr = cfwPtr->framePtr;
- *wordPtr = eiPtr->word;
+ *wordPtr = cfwPtr->word;
return;
}
}
@@ -8072,6 +8090,16 @@ TclNRTailcallObjCmd(
* TclNRAddCallBack macro to build the callback)
*/
+ /*
+ * In a bytecode execution context the engine has called
+ * TclArgumentBCEnter() which, due to the tailcall, is not paired with a
+ * regular TclArgumentBCRelease. Get rid of it on our own.
+ */
+
+ if (iPtr->cmdFramePtr->type == TCL_LOCATION_BC) {
+ TclArgumentBCRelease (interp, iPtr->cmdFramePtr);
+ }
+
TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
tailcallPtr = TOP_CB(interp);
TOP_CB(interp) = tailcallPtr->nextPtr;
@@ -8182,12 +8210,14 @@ static const CorContext NULL_CONTEXT = {NULL, NULL, NULL};
#define SAVE_CONTEXT(context) \
(context).framePtr = iPtr->framePtr; \
(context).varFramePtr = iPtr->varFramePtr; \
- (context).cmdFramePtr = iPtr->cmdFramePtr
+ (context).cmdFramePtr = iPtr->cmdFramePtr; \
+ (context).lineLABCPtr = iPtr->lineLABCPtr
#define RESTORE_CONTEXT(context) \
iPtr->framePtr = (context).framePtr; \
iPtr->varFramePtr = (context).varFramePtr; \
- iPtr->cmdFramePtr = (context).cmdFramePtr
+ iPtr->cmdFramePtr = (context).cmdFramePtr; \
+ iPtr->lineLABCPtr = (context).lineLABCPtr
#define iPtr ((Interp *) interp)
@@ -8384,7 +8414,8 @@ NRCoroutineExitCallback(
TclDeleteExecEnv(corPtr->eePtr);
corPtr->eePtr = NULL;
- /* RESTORE_CONTEXT(corPtr->caller); AUTOMATIC! */
+ SAVE_CONTEXT(corPtr->running);
+ RESTORE_CONTEXT(corPtr->caller);
NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr);
NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr);
@@ -8392,6 +8423,16 @@ NRCoroutineExitCallback(
iPtr->execEnvPtr = corPtr->callerEEPtr;
+ /*
+ * #280.
+ * Drop the coroutine-owned copy of the lineLABCPtr hashtable for literal
+ * command arguments in bytecode.
+ */
+
+ Tcl_DeleteHashTable(corPtr->base.lineLABCPtr);
+ ckfree((char *) corPtr->base.lineLABCPtr);
+ corPtr->base.lineLABCPtr = NULL;
+
return result;
}
@@ -8555,6 +8596,45 @@ TclNRCoroutineObjCmd(
corPtr->running = NULL_CONTEXT;
/*
+ * #280.
+ * Provide the new coroutine with its own copy of the lineLABCPtr
+ * hashtable for literal command arguments in bytecode. Note that that
+ * CFWordBC chains are not duplicated, only the entrypoints to them. This
+ * means that in the presence of coroutines each chain is potentially a
+ * tree. Like the chain -> tree conversion of the CmdFrame stack.
+ */
+
+ {
+ Tcl_HashSearch hSearch;
+ Tcl_HashEntry* hePtr;
+
+ corPtr->base.lineLABCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+ Tcl_InitHashTable(corPtr->base.lineLABCPtr, TCL_ONE_WORD_KEYS);
+
+ for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch);
+ hePtr;
+ hePtr = Tcl_NextHashEntry(&hSearch)) {
+ int isNew;
+ Tcl_HashEntry* newPtr =
+ Tcl_CreateHashEntry(corPtr->base.lineLABCPtr,
+ (char *) Tcl_GetHashKey (iPtr->lineLABCPtr, hePtr),
+ &isNew);
+ Tcl_SetHashValue(newPtr, Tcl_GetHashValue(hePtr));
+ }
+
+ /*
+ * The new copy is immediately plugged interpreter for use by the
+ * first coroutine commands (see below). The interp's copy of the
+ * table is already saved, see the SAVE_CONTEXT found just above this
+ * whole code block. This also properly prepares us for the
+ * SAVE/RESTORE dances during yields which swizzle the pointers
+ * around.
+ */
+
+ iPtr->lineLABCPtr = corPtr->base.lineLABCPtr;
+ }
+
+ /*
* Eval things in 'uplevel #0', except for the very first command lookup
* which should be looked up in caller's context.
*
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index a00fff8..a3a5841 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.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: tclCmdAH.c,v 1.116 2009/03/21 09:42:06 msofer Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.117 2009/07/14 16:34:08 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -1852,6 +1852,7 @@ TclNRForObjCmd(
{
int result;
Interp *iPtr = (Interp *) interp;
+ ForIterData* iterPtr;
if (objc != 5) {
Tcl_WrongNumArgs(interp, 1, objv, "start test next command");
@@ -1870,8 +1871,15 @@ TclNRForObjCmd(
return result;
}
- TclNRAddCallback(interp, TclNRForIterCallback, objv[2], objv[4],
- objv[3], "\n (\"for\" body line %d)");
+ TclSmallAllocEx (interp, sizeof(ForIterData), iterPtr);
+ iterPtr->cond = objv[2];
+ iterPtr->body = objv[4];
+ iterPtr->next = objv[3];
+ iterPtr->msg = "\n (\"for\" body line %d)";
+ iterPtr->word = 4;
+
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
+ NULL, NULL);
return TCL_OK;
}
@@ -1882,10 +1890,11 @@ TclNRForIterCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *cond = data[0];
- Tcl_Obj *body = data[1];
- Tcl_Obj *next = data[2];
- char *msg = data[3];
+ ForIterData* iterPtr = data[0];
+ Tcl_Obj *cond = iterPtr->cond;
+ Tcl_Obj *body = iterPtr->body;
+ Tcl_Obj *next = iterPtr->next;
+ char *msg = iterPtr->msg;
int value;
if ((result != TCL_OK) && (result != TCL_CONTINUE)) {
@@ -1901,17 +1910,19 @@ TclNRForIterCallback(
Tcl_ResetResult(interp);
result = Tcl_ExprBooleanObj(interp, cond, &value);
if (result != TCL_OK) {
+ TclSmallFreeEx (interp, iterPtr);
return result;
}
if (value) {
/* TIP #280. */
if (next) {
- TclNRAddCallback(interp, ForNextCallback, cond, body, next, msg);
+ TclNRAddCallback(interp, ForNextCallback, iterPtr, NULL, NULL,
+ NULL);
} else {
- TclNRAddCallback(interp, TclNRForIterCallback, cond, body, NULL,
- msg);
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL,
+ NULL);
}
- return TclNREvalObjEx(interp, body, 0, iPtr->cmdFramePtr, 2);
+ return TclNREvalObjEx(interp, body, 0, iPtr->cmdFramePtr, iterPtr->word);
}
done:
@@ -1925,6 +1936,7 @@ TclNRForIterCallback(
Tcl_AppendObjToErrorInfo(interp,
Tcl_ObjPrintf(msg, Tcl_GetErrorLine(interp)));
}
+ TclSmallFreeEx (interp, iterPtr);
return result;
}
@@ -1935,10 +1947,8 @@ ForNextCallback(
int result)
{
Interp *iPtr = (Interp *) interp;
- Tcl_Obj *cond = data[0];
- Tcl_Obj *body = data[1];
- Tcl_Obj *next = data[2];
- char *msg = data[3];
+ ForIterData* iterPtr = data[0];
+ Tcl_Obj *next = iterPtr->next;
if ((result == TCL_OK) || (result == TCL_CONTINUE)) {
/*
@@ -1952,12 +1962,13 @@ ForNextCallback(
if ((result != TCL_BREAK) && (result != TCL_OK)) {
if (result == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (\"for\" loop-end command)");
+ TclSmallFreeEx (interp, iterPtr);
}
return result;
}
}
- TclNRAddCallback(interp, TclNRForIterCallback, cond, body, next, msg);
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
return result;
}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 2021b5b..d6f2987 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.184 2009/07/12 18:04:33 dkf Exp $
+ * RCS: @(#) $Id: tclCmdMZ.c,v 1.185 2009/07/14 16:34:08 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -4601,6 +4601,8 @@ TclNRWhileObjCmd(
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
+ ForIterData* iterPtr;
+
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "test command");
return TCL_ERROR;
@@ -4610,8 +4612,15 @@ TclNRWhileObjCmd(
* We reuse [for]'s callback, passing a NULL for the 'next' script.
*/
- TclNRAddCallback(interp, TclNRForIterCallback, objv[1], objv[2],
- NULL, "\n (\"while\" body line %d)");
+ TclSmallAllocEx (interp, sizeof(ForIterData), iterPtr);
+ iterPtr->cond = objv[1];
+ iterPtr->body = objv[2];
+ iterPtr->next = NULL;
+ iterPtr->msg = "\n (\"while\" body line %d)";
+ iterPtr->word = 2;
+
+ TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL,
+ NULL, NULL);
return TCL_OK;
}
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 14ed9a0..a1a7168 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.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: tclCompile.c,v 1.167 2009/06/13 14:31:54 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.168 2009/07/14 16:34:08 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -432,8 +432,6 @@ static void PrintSourceToObj(Tcl_Obj *appendObj,
static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
Tcl_Token *tokenPtr, const char *cmd, int len,
int numWords, int line, int **lines);
-static void EnterCmdWordIndex(ExtCmdLoc *eclPtr, Tcl_Obj* obj,
- int pc, int word);
/*
* The structure below defines the bytecode Tcl object type by means of
@@ -815,10 +813,7 @@ TclCleanupByteCode(
ckfree((char *) eclPtr->loc);
}
- /* Release index of literals as well. */
- if (eclPtr->eiloc != NULL) {
- ckfree((char *) eclPtr->eiloc);
- }
+ Tcl_DeleteHashTable (&eclPtr->litInfo);
ckfree((char *) eclPtr);
Tcl_DeleteHashEntry(hePtr);
@@ -910,9 +905,7 @@ TclInitCompileEnv(
envPtr->extCmdMapPtr->nloc = 0;
envPtr->extCmdMapPtr->nuloc = 0;
envPtr->extCmdMapPtr->path = NULL;
- envPtr->extCmdMapPtr->eiloc = NULL;
- envPtr->extCmdMapPtr->neiloc = 0;
- envPtr->extCmdMapPtr->nueiloc = 0;
+ Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS);
if ((invoker == NULL) || (invoker->type == TCL_LOCATION_EVAL_LIST)) {
/*
@@ -921,8 +914,40 @@ TclInitCompileEnv(
*/
envPtr->line = 1;
- envPtr->extCmdMapPtr->type =
+ if (iPtr->evalFlags & TCL_EVAL_FILE) {
+ iPtr->evalFlags &= ~TCL_EVAL_FILE;
+ envPtr->extCmdMapPtr->type = TCL_LOCATION_SOURCE;
+
+ if (iPtr->scriptFile) {
+ /*
+ * Normalization here, to have the correct pwd. Should have
+ * negligible impact on performance, as the norm should have
+ * been done already by the 'source' invoking us, and it
+ * caches the result.
+ */
+
+ Tcl_Obj *norm = Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile);
+
+ if (norm == NULL) {
+ /*
+ * Error message in the interp result. No place to put
+ * it. And no place to serve the error itself to either.
+ * Fake a path, empty string.
+ */
+
+ TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
+ } else {
+ envPtr->extCmdMapPtr->path = norm;
+ }
+ } else {
+ TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, "");
+ }
+
+ Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
+ } else {
+ envPtr->extCmdMapPtr->type =
(envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
+ }
} else {
/*
* Initialize the compiler using the context, making counting absolute
@@ -988,6 +1013,8 @@ TclInitCompileEnv(
TclStackFree(interp, ctxPtr);
}
+ envPtr->extCmdMapPtr->start = envPtr->line;
+
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
envPtr->auxDataArrayNext = 0;
envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
@@ -1473,13 +1500,6 @@ TclCompileScript(
*/
objIndex = TclRegisterNewLiteral(envPtr,
tokenPtr[1].start, tokenPtr[1].size);
-
- if (eclPtr->type == TCL_LOCATION_SOURCE) {
- EnterCmdWordIndex(eclPtr,
- envPtr->literalArrayPtr[objIndex].objPtr,
- envPtr->codeNext - envPtr->codeStart,
- wordIdx);
- }
}
TclEmitPush(objIndex, envPtr);
} /* for loop */
@@ -1509,6 +1529,15 @@ TclCompileScript(
TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
TclAdjustStackDepth((1-wordIdx), envPtr);
} else if (wordIdx > 0) {
+ /*
+ * Save PC -> command map for the TclArgumentBC* functions.
+ */
+
+ int isnew;
+ Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
+ (char*) (envPtr->codeNext - envPtr->codeStart), &isnew);
+ Tcl_SetHashValue(hePtr, (char*) wlineat);
+
if (wordIdx <= 255) {
TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
} else {
@@ -2477,39 +2506,6 @@ EnterCmdWordData(
eclPtr->nuloc ++;
}
-static void
-EnterCmdWordIndex(
- ExtCmdLoc *eclPtr,
- Tcl_Obj *obj,
- int pc,
- int word)
-{
- ExtIndex* eiPtr;
-
- if (eclPtr->nueiloc >= eclPtr->neiloc) {
- /*
- * Expand the ExtIndex array by allocating more storage from the heap.
- * The currently allocated ECL entries are stored from eclPtr->loc[0]
- * up to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
- */
-
- size_t currElems = eclPtr->neiloc;
- size_t newElems = (currElems ? 2*currElems : 1);
- size_t newBytes = newElems * sizeof(ExtIndex);
-
- eclPtr->eiloc = (ExtIndex *)
- ckrealloc((char *)(eclPtr->eiloc), newBytes);
- eclPtr->neiloc = newElems;
- }
-
- eiPtr = &eclPtr->eiloc[eclPtr->nueiloc];
- eiPtr->obj = obj;
- eiPtr->pc = pc;
- eiPtr->word = word;
-
- eclPtr->nueiloc++;
-}
-
/*
*----------------------------------------------------------------------
*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index a9b8545..75dc236 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -9,7 +9,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.116 2009/05/08 01:02:26 msofer Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.117 2009/07/14 16:34:08 andreas_kupries Exp $
*/
#ifndef _TCLCOMPILATION
@@ -134,18 +134,23 @@ typedef struct ECL {
* command. */
} ECL;
-/* ExtIndex defined in tclInt.h */
-
typedef struct ExtCmdLoc {
int type; /* Context type. */
+ int start; /* Starting line for compiled script. Needed
+ * for the extended recompile check in
+ * tclCompileObj. */
Tcl_Obj *path; /* Path of the sourced file the command is
* in. */
ECL *loc; /* Command word locations (lines). */
int nloc; /* Number of allocated entries in 'loc'. */
int nuloc; /* Number of used entries in 'loc'. */
- ExtIndex* eiloc;
- int neiloc;
- int nueiloc;
+ Tcl_HashTable litInfo; /* Indexed by bytecode 'PC', to have the
+ * information accessible per command and
+ * argument, not per whole bytecode. Value is
+ * index of command in 'loc', giving us the
+ * literals to associate with line information
+ * as command argument, see
+ * TclArgumentBCEnter() */
} ExtCmdLoc;
/*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index aac36da..5139dad 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,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.440 2009/07/12 18:04:33 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.441 2009/07/14 16:34:08 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -1517,6 +1517,91 @@ TclCompileObj(
}
/*
+ * #280.
+ * Literal sharing fix. This part of the fix is not required by 8.4
+ * nor 8.5, because they eval-direct any literals, so just saving the
+ * argument locations per command in bytecode is enough, embedded
+ * 'eval' commands, etc. get the correct information.
+ *
+ * But in 8.6 all the embedded script are compiled, and the resulting
+ * bytecode stored in the literal. Now the shared literal has bytecode
+ * with location data for _one_ particular location this literal is
+ * found at. If we get executed from a different location the bytecode
+ * has to be recompiled to get the correct locations. Not doing this
+ * will execute the saved bytecode with data for a different location,
+ * causing 'info frame' to point to the wrong place in the sources.
+ *
+ * Future optimizations ...
+ * (1) Save the location data (ExtCmdLoc) keyed by start line. In that
+ * case we recompile once per location of the literal, but not
+ * continously, because the moment we have all locations we do not
+ * need to recompile any longer.
+ *
+ * (2) Alternative: Do not recompile, tell the execution engine the
+ * offset between saved starting line and actual one. Then modify
+ * the users to adjust the locations they have by this offset.
+ *
+ * (3) Alternative 2: Do not fully recompile, adjust just the location
+ * information.
+ */
+
+ {
+ Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
+ (char *) codePtr);
+ if (hePtr) {
+ ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
+ int redo = 0;
+
+ if (invoker) {
+ CmdFrame *ctxPtr = (CmdFrame *)
+ TclStackAlloc(interp, sizeof(CmdFrame));
+ *ctxPtr = *invoker;
+
+ if (invoker->type == TCL_LOCATION_BC) {
+ /*
+ * Note: Type BC => ctx.data.eval.path is not used.
+ * ctx.data.tebc.codePtr is used instead.
+ */
+
+ TclGetSrcInfoForPc(ctxPtr);
+ if (ctxPtr->type == TCL_LOCATION_SOURCE) {
+ /*
+ * The reference made by 'TclGetSrcInfoForPc' is dead.
+ */
+ Tcl_DecrRefCount(ctxPtr->data.eval.path);
+ ctxPtr->data.eval.path = NULL;
+ }
+ }
+
+ if (word < ctxPtr->nline) {
+ /*
+ * Note: We do not care if the line[word] is -1. This
+ * is a difference and requires a recompile (location
+ * changed from absolute to relative, literal is used
+ * fixed and through variable)
+ *
+ * Example:
+ * test info-32.0 using literal of info-24.8
+ * (dict with ... vs set body ...).
+ */
+ redo =
+ ((eclPtr->type == TCL_LOCATION_SOURCE) &&
+ (eclPtr->start != ctxPtr->line[word])) ||
+ ((eclPtr->type == TCL_LOCATION_BC) &&
+ (ctxPtr->type == TCL_LOCATION_SOURCE))
+ ;
+ }
+
+ TclStackFree(interp, ctxPtr);
+ }
+
+ if (redo) {
+ goto recompileObj;
+ }
+ }
+ }
+
+ /*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
@@ -1940,14 +2025,12 @@ TclExecuteByteCode(
bcFramePtr->nextPtr = iPtr->cmdFramePtr;
bcFramePtr->nline = 0;
bcFramePtr->line = NULL;
-
+ bcFramePtr->litarg = NULL;
bcFramePtr->data.tebc.codePtr = codePtr;
bcFramePtr->data.tebc.pc = NULL;
bcFramePtr->cmd.str.cmd = NULL;
bcFramePtr->cmd.str.len = 0;
- TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,bcFramePtr);
-
if (iPtr->execEnvPtr->rewind) {
result = TCL_ERROR;
goto abnormalReturn;
@@ -1962,6 +2045,8 @@ TclExecuteByteCode(
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
+ TclArgumentBCRelease((Tcl_Interp*) iPtr, bcFramePtr);
+
/*
* If the CallFrame is marked as tailcalling, keep tailcalling
*/
@@ -2760,6 +2845,9 @@ TclExecuteByteCode(
instructionCount = 1;
+ TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc,
+ codePtr, bcFramePtr, pc - codePtr->codeStart);
+
DECACHE_STACK_INFO();
result = TclNREvalObjv(interp, objc, objv,
@@ -2773,6 +2861,8 @@ TclExecuteByteCode(
goto nonRecursiveCallStart;
}
+ TclArgumentBCRelease((Tcl_Interp*) iPtr, bcFramePtr);
+
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr->nextPtr);
@@ -7794,8 +7884,6 @@ TclExecuteByteCode(
}
}
- TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
-
oldBottomPtr = bottomPtr->prevBottomPtr;
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
TclStackFree(interp, bottomPtr); /* free my stack */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 007facd..7374b23 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.427 2009/07/12 18:04:33 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.428 2009/07/14 16:34:09 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -1114,7 +1114,10 @@ typedef struct CmdFrame {
CallFrame *framePtr; /* Procedure activation record, may be
* NULL. */
struct CmdFrame *nextPtr; /* Link to calling frame. */
-
+ const struct CFWordBC* litarg; /* Link to set of literal arguments which
+ * have ben pushed on the lineLABCPtr stack
+ * by TclArgumentBCEnter(). These will be
+ * removed by TclArgumentBCRelease. */
/*
* Data needed for Eval vs TEBC
*
@@ -1171,19 +1174,16 @@ typedef struct CFWord {
* stack. */
} CFWord;
-typedef struct ExtIndex {
- Tcl_Obj *obj; /* Reference to the word. */
+typedef struct CFWordBC {
+ Tcl_Obj* obj; /* Back reference to hashtable key */
+ CmdFrame *framePtr; /* CmdFrame to access. */
int pc; /* Instruction pointer of a command in
* ExtCmdLoc.loc[.] */
int word; /* Index of word in
* ExtCmdLoc.loc[cmd]->line[.] */
-} ExtIndex;
-
-typedef struct CFWordBC {
- CmdFrame *framePtr; /* CmdFrame to access. */
- ExtIndex *eiPtr; /* Word info: PC and index. */
- int refCount; /* Number of times the word is on the
- * stack. */
+ struct CFWordBC* prevPtr; /* Previous entry in stack for same Tcl_Obj */
+ struct CFWordBC* nextPtr; /* Next entry for same command call. See
+ * CmdFrame litarg field for the list start. */
} CFWordBC;
/*
@@ -1345,7 +1345,8 @@ typedef struct ExecStack {
typedef struct CorContext {
struct CallFrame *framePtr;
struct CallFrame *varFramePtr;
- struct CmdFrame *cmdFramePtr;
+ struct CmdFrame *cmdFramePtr; /* See Interp.cmdFramePtr */
+ Tcl_HashTable *lineLABCPtr; /* See Interp.lineLABCPtr */
} CorContext;
typedef struct CoroutineData {
@@ -2612,6 +2613,23 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd;
MODULE_SCOPE void TclClearTailcall(Tcl_Interp *interp,
struct TEOV_callback *tailcallPtr);
+/*
+ * This structure holds the data for the various iteration callbacks used to
+ * NRE the 'for' and 'while' commands. We need a separate structure because we
+ * have more than the 4 client data entries we can provide directly thorugh
+ * the callback API. It is the 'word' information which puts us over the
+ * limit. It is needed because the loop body is argument 4 of 'for' and
+ * argument 2 of 'while'. Not providing the correct index confuses the #280
+ * code. We TclSmallAlloc/Free this.
+ */
+
+typedef struct ForIterData {
+ Tcl_Obj* cond; /* loop condition expression */
+ Tcl_Obj* body; /* loop body */
+ Tcl_Obj* next; /* loop step script, NULL for 'while' */
+ char* msg; /* error message part */
+ int word; /* Index of the body script in the command */
+} ForIterData;
/*
*----------------------------------------------------------------
@@ -2629,9 +2647,10 @@ MODULE_SCOPE void TclArgumentEnter(Tcl_Interp *interp,
MODULE_SCOPE void TclArgumentRelease(Tcl_Interp *interp,
Tcl_Obj *objv[], int objc);
MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp *interp,
- void *codePtr, CmdFrame *cfPtr);
+ Tcl_Obj* objv[], int objc,
+ void *codePtr, CmdFrame *cfPtr, int pc);
MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp *interp,
- void *codePtr);
+ CmdFrame *cfPtr);
MODULE_SCOPE void TclArgumentGet(Tcl_Interp *interp, Tcl_Obj *obj,
CmdFrame **cfPtrPtr, int *wordPtr);
MODULE_SCOPE int TclArraySet(Tcl_Interp *interp,
diff --git a/tests/info.test b/tests/info.test
index c062861..53a0e76 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -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: info.test,v 1.63 2008/10/14 16:48:11 dgp Exp $
+# RCS: @(#) $Id: info.test,v 1.64 2009/07/14 16:34:09 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -1418,6 +1418,24 @@ test info-38.7 {location information for arg substitution} -constraints testeval
* {type source line 2298 file tcltest.tcl cmd {uplevel 1 $script} proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
+# literal sharing
+
+test info-39.0 {location information not confused by literal sharing} -body {
+ namespace eval ::foo {}
+ proc ::foo::bar {} {
+ lappend res {}
+ lappend res [reduce [eval {info frame 0}]]
+ lappend res [reduce [eval {info frame 0}]]
+ return $res
+ }
+ set res [::foo::bar]
+ namespace delete ::foo
+ join $res \n
+} -result {
+type source line 1427 file info.test cmd {info frame 0} proc ::foo::bar level 0
+type source line 1428 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
# cleanup
catch {namespace delete test_ns_info1 test_ns_info2}