From b28a38b6fe8f6cacbdf12b371e2e5b169b5ec0a0 Mon Sep 17 00:00:00 2001 From: andreas_kupries Date: Tue, 14 Jul 2009 16:31:48 +0000 Subject: * generic/tclBasic.c (DeleteInterpProc,TclArgumentBCEnter, TclArgumentBCRelease, TclArgumentGet): * generic/tclCompile.c (EnterCmdWordIndex, TclCleanupByteCode, TclInitCompileEnv, TclCompileScript): * generic/tclCompile.h (ExtCmdLoc): * generic/tclExecute.c (TclExecuteByteCode): * generic/tclInt.h (ExtIndex, CFWordBC): * tests/info.test (info-39.0): Backport of some changes made to the Tcl head, to handle literal sharing better. The code here is much simpler (trimmed down) compared to the head as the 8.4 branch is not bytecode compiling whole files, and doesn't compile eval'd code either. 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 removes the problems with location data caused by literal sharing in proc bodies. Simplified the associated datastructures (ExtIndex is gone, as is the function EnterCmdWordIndex). --- ChangeLog | 23 +++++++++ generic/tclBasic.c | 140 ++++++++++++++++++++++++++++++++------------------- generic/tclCompile.c | 71 ++++++-------------------- generic/tclCompile.h | 13 +++-- generic/tclExecute.c | 14 +++--- generic/tclInt.h | 20 +++----- tests/info.test | 20 +++++++- 7 files changed, 169 insertions(+), 132 deletions(-) diff --git a/ChangeLog b/ChangeLog index ad05f98..d2abbe5 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,26 @@ +2009-07-14 Andreas Kupries + + * generic/tclBasic.c (DeleteInterpProc,TclArgumentBCEnter, + TclArgumentBCRelease, TclArgumentGet): + * generic/tclCompile.c (EnterCmdWordIndex, TclCleanupByteCode, + TclInitCompileEnv, TclCompileScript): + * generic/tclCompile.h (ExtCmdLoc): + * generic/tclExecute.c (TclExecuteByteCode): + * generic/tclInt.h (ExtIndex, CFWordBC): + * tests/info.test (info-39.0): + + Backport of some changes made to the Tcl head, to handle literal + sharing better. The code here is much simpler (trimmed down) + compared to the head as the 8.4 branch is not bytecode compiling + whole files, and doesn't compile eval'd code either. + + 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 removes the problems with location data caused by literal + sharing in proc bodies. Simplified the associated datastructures + (ExtIndex is gone, as is the function EnterCmdWordIndex). + 2009-06-13 Don Porter * generic/tclCompile.c: The value stashed in iPtr->compiledProcPtr diff --git a/generic/tclBasic.c b/generic/tclBasic.c index dbdcd7c..78bc47f 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.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: tclBasic.c,v 1.75.2.34 2008/08/14 02:12:25 das Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.35 2009/07/14 16:31:48 andreas_kupries Exp $ */ #include "tclInt.h" @@ -50,7 +50,6 @@ static int EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script static int EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Token *tokenPtr, int count, int line)); - #endif #ifdef USE_DTRACE @@ -1202,9 +1201,7 @@ DeleteInterpProc(interp) ckfree ((char*) eclPtr->loc); } - if (eclPtr->eiloc != NULL) { - ckfree ((char*) eclPtr->eiloc); - } + Tcl_DeleteHashTable (&eclPtr->litInfo); ckfree ((char*) eclPtr); Tcl_DeleteHashEntry (hPtr); @@ -4454,46 +4451,68 @@ TclArgumentRelease(interp,objv,objc) */ void -TclArgumentBCEnter(interp,codePtr,cfPtr) +TclArgumentBCEnter(interp, objv, objc, codePtr, cfPtr, pc) 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); if (hePtr) { ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); - int i; + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc); - for (i=0; i < eclPtr->nueiloc; i++) { + if (hePtr) { + int word; + int cmd = (int) Tcl_GetHashValue(hePtr); + ECL* ePtr = &eclPtr->loc[cmd]; - ExtIndex* eiPtr = &eclPtr->eiloc[i]; - Tcl_Obj* obj = eiPtr->obj; - int new; - Tcl_HashEntry* hPtr; - CFWordBC* cfwPtr; + /* + * 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. + */ - 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. - */ - 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. - */ - cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); - cfwPtr->refCount ++; - } - } /* for */ + 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->pc = pc; + cfwPtr->word = word; + + 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); + } + + Tcl_SetHashValue (hPtr, cfwPtr); + } + } /* for */ + } /* if */ } /* if */ } @@ -4518,33 +4537,48 @@ TclArgumentBCEnter(interp,codePtr,cfPtr) */ void -TclArgumentBCRelease(interp,codePtr) +TclArgumentBCRelease(interp, objv, objc, codePtr, pc) Tcl_Interp* interp; + Tcl_Obj* objv[]; + int objc; void* codePtr; + int pc; { Interp* iPtr = (Interp*) interp; Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); if (hePtr) { ExtCmdLoc* eclPtr = (ExtCmdLoc*) 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 = (CFWordBC*) Tcl_GetHashValue (hPtr); + hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc); - cfwPtr->refCount --; - if (cfwPtr->refCount > 0) { continue; } + if (hePtr) { + int cmd = (int) Tcl_GetHashValue(hePtr); + ECL* ePtr = &eclPtr->loc[cmd]; + int word; - ckfree ((char*) cfwPtr); - Tcl_DeleteHashEntry (hPtr); - } /* for */ - } /* if */ + /* + * Iterate in reverse order, to properly match our pop to the push + * in TclArgumentBCEnter(). + */ + for (word = objc-1; word >= 1; word--) { + if (ePtr->line[word] >= 0) { + Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr, + (char *) objv[word]); + if (hPtr) { + CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); + + if (cfwPtr->prevPtr) { + Tcl_SetHashValue(hPtr, cfwPtr->prevPtr); + } else { + Tcl_DeleteHashEntry(hPtr); + } + + ckfree((char *) cfwPtr); + } + } + } + } + } } /* @@ -4608,12 +4642,12 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj); if (hPtr) { CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); - ExtIndex* eiPtr = cfwPtr->eiPtr; framePtr = cfwPtr->framePtr; - framePtr->data.tebc.pc = ((ByteCode*) framePtr->data.tebc.codePtr)->codeStart + eiPtr->pc; + framePtr->data.tebc.pc = ((ByteCode*) + framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc; *cfPtrPtr = cfwPtr->framePtr; - *wordPtr = eiPtr->word; + *wordPtr = cfwPtr->word; return; } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 98ccc50..b6d486e 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.43.2.14 2009/06/13 14:38:44 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.43.2.15 2009/07/14 16:31:49 andreas_kupries Exp $ */ #include "tclInt.h" @@ -308,9 +308,6 @@ static void EnterCmdWordData _ANSI_ARGS_(( ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr, CONST char* cmd, int len, int numWords, int line, int** lines)); - -static void EnterCmdWordIndex _ANSI_ARGS_(( - ExtCmdLoc *eclPtr, Tcl_Obj* obj, int pc, int word)); #endif @@ -709,7 +706,7 @@ TclCleanupByteCode(codePtr) if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount (eclPtr->path); } - for (i=0; i< eclPtr->nuloc; i++) { + for (i=0; i < eclPtr->nuloc; i++) { ckfree ((char*) eclPtr->loc[i].line); } @@ -717,10 +714,7 @@ TclCleanupByteCode(codePtr) 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); @@ -815,9 +809,7 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word) 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)) { @@ -1276,14 +1268,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) objIndex = TclRegisterNewLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); -#ifdef TCL_TIP280 - if (eclPtr->type == TCL_LOCATION_SOURCE) { - EnterCmdWordIndex (eclPtr, - envPtr->literalArrayPtr[objIndex].objPtr, - envPtr->codeNext - envPtr->codeStart, - wordIdx); - } -#endif } TclEmitPush(objIndex, envPtr); } else { @@ -1304,6 +1288,16 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) */ if (wordIdx > 0) { +#ifdef TCL_TIP280 + /* + * 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); +#endif if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { @@ -1326,7 +1320,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr) * the reduced form now */ ckfree ((char*) eclPtr->loc [wlineat].line); - eclPtr->loc [wlineat].line = wlines; + eclPtr->loc [wlineat].line = wlines; #endif } /* end if parse.numWords > 0 */ @@ -2462,7 +2456,7 @@ EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines) size_t currBytes = currElems * sizeof(ECL); size_t newBytes = newElems * sizeof(ECL); ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes); - + /* * Copy from old ECL array to new, free old ECL array if * needed. @@ -2500,39 +2494,6 @@ EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines) *wlines = wwlines; eclPtr->nuloc ++; } - -static void -EnterCmdWordIndex (eclPtr, obj, pc, word) - 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 ++; -} #endif /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 69b0c82..b3431f8 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.33.2.6 2008/08/14 02:12:27 das Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.33.2.7 2009/07/14 16:31:49 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION @@ -140,15 +140,20 @@ typedef struct ECL { int nline; /* Number of words in the command */ int* line; /* line information for all words in the command */ } ECL; + typedef struct ExtCmdLoc { int type; /* Context type */ 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; #endif diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 065024c..8dcf877 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclExecute.c,v 1.94.2.28 2009/03/20 14:22:54 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.94.2.29 2009/07/14 16:31:49 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1245,8 +1245,6 @@ TclExecuteByteCode(interp, codePtr) bcFrame.data.tebc.pc = NULL; bcFrame.cmd.str.cmd = NULL; bcFrame.cmd.str.len = 0; - - TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,&bcFrame); #endif #ifdef TCL_COMPILE_DEBUG @@ -1584,12 +1582,18 @@ TclExecuteByteCode(interp, codePtr) #ifdef TCL_TIP280 bcFrame.data.tebc.pc = pc; iPtr->cmdFramePtr = &bcFrame; + TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc, + codePtr, &bcFrame, + pc - codePtr->codeStart); #endif DECACHE_STACK_INFO(); Tcl_ResetResult(interp); result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); CACHE_STACK_INFO(); #ifdef TCL_TIP280 + TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc, + codePtr, + pc - codePtr->codeStart); iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; #endif @@ -4523,10 +4527,6 @@ TclExecuteByteCode(interp, codePtr) } eePtr->stackTop = initStackTop; -#ifdef TCL_TIP280 - TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr); -#endif - return result; #undef STATIC_CATCH_STACK_SIZE } diff --git a/generic/tclInt.h b/generic/tclInt.h index 43870e7..fc56e6e 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.118.2.33 2009/04/27 22:10:28 ferrieux Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.118.2.34 2009/07/14 16:31:49 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -917,17 +917,11 @@ typedef struct CFWord { int refCount; /* #times the word is on the stack */ } CFWord; -typedef struct ExtIndex { - Tcl_Obj* obj; /* Reference to the word */ - 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 acess */ - ExtIndex* eiPtr; /* Word info: PC and index */ - int refCount; /* #times the word is on the stack */ + int pc; /* Instruction pointer of a command in ExtCmdLoc.loc[.] */ + int word; /* Index of word in ExtCmdLoc.loc[cmd]->{line,literal}[.] */ + struct CFWordBC* prevPtr; } CFWordBC; #endif /* TCL_TIP280 */ @@ -1873,9 +1867,11 @@ EXTERN void TclArgumentEnter _ANSI_ARGS_((Tcl_Interp* interp, EXTERN void TclArgumentRelease _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* objv[], int objc)); EXTERN void TclArgumentBCEnter _ANSI_ARGS_((Tcl_Interp* interp, - void* codePtr, CmdFrame* cfPtr)); + Tcl_Obj* objv[], int objc, + void* codePtr, CmdFrame* cfPtr, int pc)); EXTERN void TclArgumentBCRelease _ANSI_ARGS_((Tcl_Interp* interp, - void* codePtr)); + Tcl_Obj* objv[], int objc, + void* codePtr, int pc)); EXTERN void TclArgumentGet _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, CmdFrame** cfPtrPtr, int* wordPtr)); diff --git a/tests/info.test b/tests/info.test index b30a4be..b655e30 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.24.2.11 2008/07/28 20:01:12 andreas_kupries Exp $ +# RCS: @(#) $Id: info.test,v 1.24.2.12 2009/07/14 16:31:49 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -1205,6 +1205,24 @@ test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -const * {type source line 1200 file info.test cmd datal proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- +# literal sharing + +test info-39.0 {location information not confused by literal sharing} -constraints tip280 -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 1214 file info.test cmd {info frame 0} proc ::foo::bar level 0 +type source line 1215 file info.test cmd {info frame 0} proc ::foo::bar level 0} + +# ------------------------------------------------------------------------- # cleanup catch {namespace delete test_ns_info1 test_ns_info2} -- cgit v0.12