1 files changed, 150 insertions, 70 deletions

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.
      *