diff options
author | andreas_kupries <andreas_kupries@noemail.net> | 2009-07-14 16:31:48 (GMT) |
---|---|---|
committer | andreas_kupries <andreas_kupries@noemail.net> | 2009-07-14 16:31:48 (GMT) |
commit | 60dff8715e8b4eb2187b5a678b6e2c21ee385e63 (patch) | |
tree | 76e0629bdd11d03e1d08818f19358386c3c14018 /generic/tclBasic.c | |
parent | 9c311364b0a0903569d5051557932e57541f3b32 (diff) | |
download | tcl-60dff8715e8b4eb2187b5a678b6e2c21ee385e63.zip tcl-60dff8715e8b4eb2187b5a678b6e2c21ee385e63.tar.gz tcl-60dff8715e8b4eb2187b5a678b6e2c21ee385e63.tar.bz2 |
* 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).
FossilOrigin-Name: fabfd40ca1f07badc6d2a723bc1f3c2dd7cc2875
Diffstat (limited to 'generic/tclBasic.c')
-rw-r--r-- | generic/tclBasic.c | 140 |
1 files changed, 87 insertions, 53 deletions
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; } } |