From 08c08fbd919645722f3a2fe5db61c2e4dfa97d2c Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 12 Jul 2009 14:51:30 +0000 Subject: Reorganize method cache handling a bit to better support itcl nasty cases. [Bug 1895546] --- ChangeLog | 7 +++++++ generic/tclOO.c | 60 +++++++++++++++++++++++++++++++++-------------------- generic/tclOOCall.c | 18 ++++++++++------ generic/tclOOInt.h | 5 +++-- 4 files changed, 60 insertions(+), 30 deletions(-) diff --git a/ChangeLog b/ChangeLog index 015eb9a..4ba0279 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,10 @@ +2009-07-12 Donal K. Fellows + + * generic/tclOOCall.c (TclOOGetCallContext): [Bug 1895546]: Changed + * generic/tclOO.c (TclOOObjectCmdCore): the way that the cache is + managed so that when itcl does cunning things, those cunning things + can be cached properly. + 2009-07-11 Donal K. Fellows * doc/vwait.n: Substantially increased the discussion of issues and diff --git a/generic/tclOO.c b/generic/tclOO.c index 1ba0ba8..c1e8678 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclOO.c,v 1.22 2009/05/08 08:48:19 dkf Exp $ + * RCS: @(#) $Id: tclOO.c,v 1.23 2009/07/12 14:51:30 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -625,7 +625,7 @@ ObjectRenamedTrace( AddRef(oPtr); oPtr->flags |= OBJECT_DELETED; - contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR); + contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL); if (contextPtr != NULL) { int result; Tcl_InterpState state; @@ -1330,7 +1330,8 @@ Tcl_NewObjectInstance( */ if (objc >= 0) { - CallContext *contextPtr = TclOOGetCallContext(oPtr,NULL,CONSTRUCTOR); + CallContext *contextPtr = + TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr != NULL) { int result; @@ -1426,7 +1427,7 @@ TclNRNewObjectInstance( *objectPtr = (Tcl_Object) oPtr; return TCL_OK; } - contextPtr = TclOOGetCallContext(oPtr,NULL,CONSTRUCTOR); + contextPtr = TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL); if (contextPtr == NULL) { *objectPtr = (Tcl_Object) oPtr; return TCL_OK; @@ -2097,34 +2098,49 @@ TclOOObjectCmdCore( methodNamePtr = objv[1]; if (oPtr->mapMethodNameProc != NULL) { register Class **startClsPtr = &startCls; + Tcl_Obj *mappedMethodName = Tcl_DuplicateObj(methodNamePtr); - methodNamePtr = Tcl_DuplicateObj(methodNamePtr); result = oPtr->mapMethodNameProc(interp, (Tcl_Object) oPtr, - (Tcl_Class *) startClsPtr, methodNamePtr); + (Tcl_Class *) startClsPtr, mappedMethodName); if (result != TCL_OK) { - if (result == TCL_ERROR) { + Tcl_DecrRefCount(mappedMethodName); + if (result == TCL_BREAK) { + goto noMapping; + } else if (result == TCL_ERROR) { Tcl_AddErrorInfo(interp, "\n (while mapping method name)"); } - Tcl_DecrRefCount(methodNamePtr); return result; } - } - Tcl_IncrRefCount(methodNamePtr); - /* - * Get the call chain. - */ + /* + * Get the call chain for the remapped name. + */ - contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, - flags | (oPtr->flags & FILTER_HANDLING)); - if (contextPtr == NULL) { - Tcl_AppendResult(interp, "impossible to invoke method \"", - TclGetString(methodNamePtr), - "\": no defined method or unknown method", NULL); - Tcl_DecrRefCount(methodNamePtr); - return TCL_ERROR; + Tcl_IncrRefCount(mappedMethodName); + contextPtr = TclOOGetCallContext(oPtr, mappedMethodName, + flags | (oPtr->flags & FILTER_HANDLING), methodNamePtr); + Tcl_DecrRefCount(mappedMethodName); + if (contextPtr == NULL) { + Tcl_AppendResult(interp, "impossible to invoke method \"", + TclGetString(methodNamePtr), + "\": no defined method or unknown method", NULL); + return TCL_ERROR; + } + } else { + /* + * Get the call chain. + */ + + noMapping: + contextPtr = TclOOGetCallContext(oPtr, methodNamePtr, + flags | (oPtr->flags & FILTER_HANDLING), NULL); + if (contextPtr == NULL) { + Tcl_AppendResult(interp, "impossible to invoke method \"", + TclGetString(methodNamePtr), + "\": no defined method or unknown method", NULL); + return TCL_ERROR; + } } - Tcl_DecrRefCount(methodNamePtr); /* * Check to see if we need to apply magical tricks to start part way diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c index c4b9ab2..e9760f7 100644 --- a/generic/tclOOCall.c +++ b/generic/tclOOCall.c @@ -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: tclOOCall.c,v 1.13 2008/10/16 22:34:18 nijtmans Exp $ + * RCS: @(#) $Id: tclOOCall.c,v 1.14 2009/07/12 14:51:30 dkf Exp $ */ #ifdef HAVE_CONFIG_H @@ -897,10 +897,13 @@ TclOOGetCallContext( Tcl_Obj *methodNameObj, /* The name of the method to get the context * for. NULL when getting a constructor or * destructor chain. */ - int flags) /* What sort of context are we looking for. + int flags, /* What sort of context are we looking for. * Only the bits PUBLIC_METHOD, CONSTRUCTOR, * PRIVATE_METHOD, DESTRUCTOR and * FILTER_HANDLING are useful. */ + Tcl_Obj *cacheInThisObj) /* What object to cache in, or NULL if it is + * to be in the same object as the + * methodNameObj. */ { CallContext *contextPtr; CallChain *callPtr; @@ -909,6 +912,9 @@ TclOOGetCallContext( Tcl_HashEntry *hPtr; Tcl_HashTable doneFilters; + if (cacheInThisObj == NULL) { + cacheInThisObj = methodNameObj; + } if (flags&(SPECIAL|FILTER_HANDLING) || (oPtr->flags&FILTER_HANDLING)) { hPtr = NULL; doFilters = 0; @@ -944,13 +950,13 @@ TclOOGetCallContext( const int reuseMask = ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD); - if (methodNameObj->typePtr == &methodNameType) { - callPtr = methodNameObj->internalRep.otherValuePtr; + if (cacheInThisObj->typePtr == &methodNameType) { + callPtr = cacheInThisObj->internalRep.otherValuePtr; if (IsStillValid(callPtr, oPtr, flags, reuseMask)) { callPtr->refCount++; goto returnContext; } - methodNameObj->typePtr->freeIntRepProc(methodNameObj); + cacheInThisObj->typePtr->freeIntRepProc(cacheInThisObj); } if (oPtr->flags & USE_CLASS_CACHE) { @@ -1067,7 +1073,7 @@ TclOOGetCallContext( } callPtr->refCount++; Tcl_SetHashValue(hPtr, callPtr); - StashCallChain(methodNameObj, callPtr); + StashCallChain(cacheInThisObj, callPtr); } else if (flags & CONSTRUCTOR) { if (oPtr->selfCls->constructorChainPtr) { TclOODeleteChain(oPtr->selfCls->constructorChainPtr); diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 1579ddb..17db3f1 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.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: tclOOInt.h,v 1.11 2009/04/11 11:18:51 dkf Exp $ + * RCS: @(#) $Id: tclOOInt.h,v 1.12 2009/07/12 14:51:30 dkf Exp $ */ #ifndef TCL_OO_INTERNAL_H @@ -512,7 +512,8 @@ MODULE_SCOPE void TclOODeleteChainCache(Tcl_HashTable *tablePtr); MODULE_SCOPE void TclOODeleteContext(CallContext *contextPtr); MODULE_SCOPE void TclOODelMethodRef(Method *method); MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr, - Tcl_Obj *methodNameObj, int flags); + Tcl_Obj *methodNameObj, int flags, + Tcl_Obj *cacheInThisObj); MODULE_SCOPE Foundation *TclOOGetFoundation(Tcl_Interp *interp); MODULE_SCOPE Tcl_Obj * TclOOGetFwdFromMethod(Method *mPtr); MODULE_SCOPE Proc * TclOOGetProcFromMethod(Method *mPtr); -- cgit v0.12