diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclBasic.c | 137 | ||||
| -rw-r--r-- | generic/tclCompile.c | 43 | ||||
| -rw-r--r-- | generic/tclCompile.h | 10 | ||||
| -rw-r--r-- | generic/tclExecute.c | 7 | ||||
| -rw-r--r-- | generic/tclInt.h | 20 |
6 files changed, 169 insertions, 59 deletions
@@ -1,3 +1,14 @@ +2008-07-22 Andreas Kupries <andreask@activestate.com> + + * generic/tclBasic.c: Reworked the handling of bytecode literals + * generic/tclCompile.c: for #280 to fix the abysmal performance + * generic/tclCompile.h: for deep recursion, replaced the linear + * generic/tclExecute.c: search through the whole stack with + * generic/tclInt.h: another hashtable and simplified the data + structure used by the compiler (array instead of hashtable). + Incidentially this also fixes the memory leak reported via [Bug + 2024937]. + 2008-07-21 Andreas Kupries <andreask@activestate.com> * generic/tclBasic.c: Extended the existing TIP #280 system (info diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4ad59c7..6ec5763 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.29 2008/07/21 19:37:40 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.75.2.30 2008/07/22 21:40:24 andreas_kupries Exp $ */ #include "tclInt.h" @@ -361,9 +361,11 @@ Tcl_CreateInterp() 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); #endif iPtr->activeVarTracePtr = NULL; @@ -1226,6 +1228,19 @@ DeleteInterpProc(interp) 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; } #endif ckfree((char *) iPtr); @@ -4413,7 +4428,82 @@ TclArgumentRelease(interp,objv,objc) Tcl_DeleteHashEntry (hPtr); } } + + +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 */ +} + /* *---------------------------------------------------------------------- * @@ -4457,43 +4547,20 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) } /* - * 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 = 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; } } #endif diff --git a/generic/tclCompile.c b/generic/tclCompile.c index d8e22e2..a1747ba 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.9 2008/07/21 19:37:43 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.43.2.10 2008/07/22 21:40:26 andreas_kupries Exp $ */ #include "tclInt.h" @@ -702,8 +702,6 @@ TclCleanupByteCode(codePtr) if (hePtr) { ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); int i; - Tcl_HashSearch hSearch; - Tcl_HashEntry *hlPtr; if (eclPtr->type == TCL_LOCATION_SOURCE) { Tcl_DecrRefCount (eclPtr->path); @@ -717,14 +715,10 @@ TclCleanupByteCode(codePtr) } /* 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); } @@ -817,7 +811,9 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word) 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) { /* Initialize the compiler for relative counting */ @@ -2496,15 +2492,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 ++; } #endif diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 8192aa4..adde52c 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.3 2008/07/21 19:37:43 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.33.2.4 2008/07/22 21:40:31 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION @@ -146,12 +146,10 @@ 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 the command in ExtCmdLoc.loc[.] */ - int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */ -} ExtIndex; EXTERN void TclEnterCmdWordIndex _ANSI_ARGS_(( ExtCmdLoc *eclPtr, Tcl_Obj* obj, int pc, int word)); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b94785d..7d0eb11 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.25 2008/04/14 16:25:49 dgp Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.94.2.26 2008/07/22 21:40:31 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1245,6 +1245,8 @@ 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 @@ -4514,6 +4516,9 @@ TclExecuteByteCode(interp, codePtr) ckfree((char *) catchStackPtr); } eePtr->stackTop = initStackTop; + + TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr); + return result; #undef STATIC_CATCH_STACK_SIZE } diff --git a/generic/tclInt.h b/generic/tclInt.h index 18f1c70..7de3d01 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.31 2008/07/21 19:37:43 andreas_kupries Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.118.2.32 2008/07/22 21:40:32 andreas_kupries Exp $ */ #ifndef _TCLINT @@ -916,6 +916,19 @@ typedef struct CFWord { int word; /* Index of the word in the command */ 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; #endif /* TCL_TIP280 */ /* @@ -1505,6 +1518,7 @@ typedef struct Interp { * values are "struct ExtCmdLoc*" (See * tclCompile.h). */ + Tcl_HashTable* lineLABCPtr; Tcl_HashTable* lineLAPtr; /* This table remembers for each * argument of a command on the @@ -1858,6 +1872,10 @@ EXTERN void TclArgumentEnter _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* objv[], int objc, CmdFrame* cf)); 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)); +EXTERN void TclArgumentBCRelease _ANSI_ARGS_((Tcl_Interp* interp, + void* codePtr)); EXTERN void TclArgumentGet _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj, CmdFrame** cfPtrPtr, int* wordPtr)); |