diff options
| -rw-r--r-- | ChangeLog | 50 | ||||
| -rw-r--r-- | generic/tclBasic.c | 220 | ||||
| -rw-r--r-- | generic/tclCmdAH.c | 43 | ||||
| -rw-r--r-- | generic/tclCmdMZ.c | 15 | ||||
| -rw-r--r-- | generic/tclCompile.c | 98 | ||||
| -rw-r--r-- | generic/tclCompile.h | 17 | ||||
| -rw-r--r-- | generic/tclExecute.c | 100 | ||||
| -rw-r--r-- | generic/tclInt.h | 47 | ||||
| -rw-r--r-- | tests/info.test | 20 |
9 files changed, 443 insertions, 167 deletions
@@ -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} |