diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBasic.c | 140 | ||||
| -rw-r--r-- | generic/tclCompile.c | 43 | ||||
| -rw-r--r-- | generic/tclCompile.h | 13 | ||||
| -rw-r--r-- | generic/tclExecute.c | 7 | ||||
| -rw-r--r-- | generic/tclInt.h | 20 |
5 files changed, 160 insertions, 63 deletions
diff --git a/generic/tclBasic.c b/generic/tclBasic.c index f7c667a..18a9857 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.324 2008/07/22 21:02:27 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.325 2008/07/22 21:41:49 andreas_kupries Exp $ */ #include "tclInt.h" @@ -498,9 +498,11 @@ Tcl_CreateInterp(void) iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable)); iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); + iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable)); Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS); Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS); + Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS); iPtr->activeVarTracePtr = NULL; @@ -1539,6 +1541,19 @@ DeleteInterpProc( Tcl_DeleteHashTable(iPtr->lineLAPtr); ckfree((char*) iPtr->lineLAPtr); iPtr->lineLAPtr = NULL; + + if (iPtr->lineLABCPtr->numEntries) { + /* + * When the interp goes away we have nothing on the stack, so + * there are no arguments, so this table has to be empty. + */ + + Tcl_Panic ("Argument location tracking table not empty"); + } + + Tcl_DeleteHashTable (iPtr->lineLABCPtr); + ckfree((char*) iPtr->lineLABCPtr); + iPtr->lineLABCPtr = NULL; } Tcl_DeleteHashTable(&iPtr->varTraces); @@ -5359,6 +5374,81 @@ TclArgumentRelease( } } + +void +TclArgumentBCEnter(interp,codePtr,cfPtr) + Tcl_Interp* interp; + void* codePtr; + CmdFrame* cfPtr; +{ + 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++) { + + ExtIndex* eiPtr = &eclPtr->eiloc[i]; + Tcl_Obj* obj = eiPtr->obj; + int new; + Tcl_HashEntry* hPtr; + CFWordBC* cfwPtr; + + 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 */ + } /* if */ +} + +void +TclArgumentBCRelease(interp,codePtr) + Tcl_Interp* interp; + void* codePtr; +{ + 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); + + cfwPtr->refCount --; + if (cfwPtr->refCount > 0) { continue; } + + ckfree ((char*) cfwPtr); + Tcl_DeleteHashEntry (hPtr); + } /* for */ + } /* if */ +} + /* *---------------------------------------------------------------------- * @@ -5403,46 +5493,20 @@ TclArgumentGet( } /* - * Check if the Tcl_Obj has location information as a bytecode literal. We - * have to scan the stack up and check all bytecode frames for a possible - * definition. + * Check if the Tcl_Obj has location information as a bytecode literal, in + * that stack. */ - for (framePtr = iPtr->cmdFramePtr; framePtr; - framePtr = framePtr->nextPtr) { - const ByteCode *codePtr; - Tcl_HashEntry *hePtr; - - if (framePtr->type != TCL_LOCATION_BC) { - continue; - } - - codePtr = framePtr->data.tebc.codePtr; - hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); - - if (hePtr) { - ExtCmdLoc *eclPtr = (ExtCmdLoc*) Tcl_GetHashValue(hePtr); - Tcl_HashEntry *hlPtr = Tcl_FindHashEntry(&eclPtr->litIndex, - (char *) obj); - - if (hlPtr) { - /* - * Convert from the current invoker CmdFrame to a CmdFrame - * refering to the actual word location. We are directly - * manipulating the relevant command frame in the frame stack. - * That is no problem because TEBC is already setting the pc - * for each invokation, so moving it somewhere will not affect - * the following commands. - */ - - ExtIndex *eiPtr = (ExtIndex*) Tcl_GetHashValue(hlPtr); + hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj); + if (hPtr) { + CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr); + ExtIndex* eiPtr = cfwPtr->eiPtr; - framePtr->data.tebc.pc = (char *) (codePtr->codeStart + - eiPtr->pc); - *cfPtrPtr = framePtr; - *wordPtr = eiPtr->word; - } - } + framePtr = cfwPtr->framePtr; + framePtr->data.tebc.pc = ((ByteCode*) framePtr->data.tebc.codePtr)->codeStart + eiPtr->pc; + *cfPtrPtr = cfwPtr->framePtr; + *wordPtr = eiPtr->word; + return; } } diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 88d8b86..79a9313 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.150 2008/07/21 22:50:34 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.151 2008/07/22 21:41:51 andreas_kupries Exp $ */ #include "tclInt.h" @@ -801,8 +801,6 @@ TclCleanupByteCode( if (hePtr) { ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); int i; - Tcl_HashSearch hSearch; - Tcl_HashEntry *hlPtr; if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount(eclPtr->path); @@ -816,14 +814,10 @@ TclCleanupByteCode( } /* Release index of literals as well. */ - for (hlPtr = Tcl_FirstHashEntry(&eclPtr->litIndex, &hSearch); - hlPtr != NULL; - hlPtr = Tcl_NextHashEntry(&hSearch)) { - ExtIndex* eiPtr = (ExtIndex*) Tcl_GetHashValue (hlPtr); - ckfree((char*) eiPtr); - Tcl_DeleteHashEntry (hlPtr); + if (eclPtr->eiloc != NULL) { + ckfree((char *) eclPtr->eiloc); } - Tcl_DeleteHashTable (&eclPtr->litIndex); + ckfree((char *) eclPtr); Tcl_DeleteHashEntry(hePtr); } @@ -913,7 +907,9 @@ TclInitCompileEnv( envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; envPtr->extCmdMapPtr->path = NULL; - Tcl_InitHashTable(&envPtr->extCmdMapPtr->litIndex, TCL_ONE_WORD_KEYS); + envPtr->extCmdMapPtr->eiloc = NULL; + envPtr->extCmdMapPtr->neiloc = 0; + envPtr->extCmdMapPtr->nueiloc = 0; if (invoker == NULL) { /* @@ -2476,15 +2472,30 @@ TclEnterCmdWordIndex (eclPtr, obj, pc, word) int pc; int word; { - int new; - ExtIndex* eiPtr = (ExtIndex*) ckalloc (sizeof (ExtIndex)); + 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; - Tcl_SetHashValue (Tcl_CreateHashEntry (&eclPtr->litIndex, - (char*) obj, &new), - eiPtr); + eclPtr->nueiloc ++; } /* diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a27bbd9..ec3cbbf 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.94 2008/07/21 22:50:34 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.95 2008/07/22 21:41:55 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION @@ -134,6 +134,8 @@ typedef struct ECL { * command. */ } ECL; +/* ExtIndex defined in tclInt.h */ + typedef struct ExtCmdLoc { int type; /* Context type. */ Tcl_Obj *path; /* Path of the sourced file the command is @@ -141,14 +143,11 @@ typedef struct ExtCmdLoc { ECL *loc; /* Command word locations (lines). */ int nloc; /* Number of allocated entries in 'loc'. */ int nuloc; /* Number of used entries in 'loc'. */ - Tcl_HashTable litIndex; /* HashValue is ExtIndex* */ + ExtIndex* eiloc; + int neiloc; + int nueiloc; } ExtCmdLoc; -typedef struct ExtIndex { - int pc; /* Instruction pointer of a command in ExtCmdLoc.loc[.] */ - int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */ -} ExtIndex; - EXTERN void TclEnterCmdWordIndex (ExtCmdLoc *eclPtr, Tcl_Obj* obj, int pc, int word); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b26d77e..0102f5a 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.386 2008/07/22 21:02:28 msofer Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.387 2008/07/22 21:41:55 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1877,6 +1877,9 @@ TclExecuteByteCode( bcFramePtr->data.tebc.pc = NULL; bcFramePtr->cmd.str.cmd = NULL; bcFramePtr->cmd.str.len = 0; + + TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,bcFramePtr); + #if (USE_NR_TEBC) } else if (tailcall) { goto tailcallEntry; @@ -7757,6 +7760,8 @@ TclExecuteByteCode( } } + TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr); + #if USE_NR_TEBC oldBottomPtr = bottomPtr->prevBottomPtr; #endif diff --git a/generic/tclInt.h b/generic/tclInt.h index dad62a8..7566e24 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -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: tclInt.h,v 1.377 2008/07/22 21:02:30 msofer Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.378 2008/07/22 21:41:55 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -1158,6 +1158,19 @@ 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 */ +} CFWordBC; + /* * The following macros define the allowed values for the type field of the * CmdFrame structure above. Some of the values occur only in the extended @@ -1877,6 +1890,7 @@ typedef struct Interp { * body. It is keyed by the address of the * Proc structure for a procedure. The values * are "struct ExtCmdLoc*" (See tclCompile.h) */ + Tcl_HashTable* lineLABCPtr; Tcl_HashTable* lineLAPtr; /* This table remembers for each argument of a * command on the execution stack the index of * the argument in the command, and the @@ -2513,6 +2527,10 @@ MODULE_SCOPE void TclArgumentEnter(Tcl_Interp* interp, Tcl_Obj* objv[], int objc, CmdFrame* cf); MODULE_SCOPE void TclArgumentRelease(Tcl_Interp* interp, Tcl_Obj* objv[], int objc); +MODULE_SCOPE void TclArgumentBCEnter(Tcl_Interp* interp, + void* codePtr, CmdFrame* cfPtr); +MODULE_SCOPE void TclArgumentBCRelease(Tcl_Interp* interp, + void* codePtr); MODULE_SCOPE void TclArgumentGet(Tcl_Interp* interp, Tcl_Obj* obj, CmdFrame** cfPtrPtr, int* wordPtr); MODULE_SCOPE int TclArraySet(Tcl_Interp *interp, |