Index: TODO =================================================================== diff -u -r24724ebae83af4e0104b349a2fb582bfc71a7475 -r877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac --- TODO (.../TODO) (revision 24724ebae83af4e0104b349a2fb582bfc71a7475) +++ TODO (.../TODO) (revision 877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac) @@ -3560,6 +3560,14 @@ - additionalal regression test file method-parameter.test - provide selective error messages for unknown nonpos args +nsf.c: + - reform of method obj lookup. new code uses + NsfInstanceMethodObjType and NsfObjectMethodObjType + to reuse earlier lookup results. Improved speed for + for methods with primitive bodies (over version before + argument parse reform: 10%-43%. + - additional compile-time option: METHOD_OBJECT_TRACE + TODO: - NsfUnexpectedNonposArgumentError() for valueInArgument, when structure settles - ouput of noleadingdash in introspection Index: generic/nsf.c =================================================================== diff -u -r24724ebae83af4e0104b349a2fb582bfc71a7475 -r877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac --- generic/nsf.c (.../nsf.c) (revision 24724ebae83af4e0104b349a2fb582bfc71a7475) +++ generic/nsf.c (.../nsf.c) (revision 877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac) @@ -163,6 +163,15 @@ } enumeratorConverterEntry; static enumeratorConverterEntry enumeratorConverterEntries[]; +static int nsfMethodEpoch = 0; +#if defined(METHOD_OBJECT_TRACE) +# define NsfMethodEpochIncr(msg) \ + nsfMethodEpoch++; \ + fprintf(stderr, "+++ methodEpoch %d %s\n", nsfMethodEpoch, msg); +#else +# define NsfMethodEpochIncr(msg) nsfMethodEpoch++ +#endif + /* * Tcl_Obj Types for Next Scripting Objects */ @@ -909,6 +918,8 @@ NsfRemoveObjectMethod(Tcl_Interp *interp, Nsf_Object *object1, CONST char *methodName) { NsfObject *object = (NsfObject *) object1; + NsfMethodEpochIncr("NsfRemoveObjectMethod"); + AliasDelete(interp, object->cmdName, methodName, 1); #if defined(NSF_WITH_ASSERTIONS) @@ -934,6 +945,8 @@ NsfClassOpt *opt = cl->opt; #endif + NsfMethodEpochIncr("NsfRemoveClassMethod"); + AliasDelete(interp, class->object.cmdName, methodName, 0); #if defined(NSF_WITH_ASSERTIONS) @@ -1727,6 +1740,7 @@ if (likely(cl->order != NULL)) { return cl->order; } + //NsfMethodEpochIncr("ComputeOrder"); return cl->order = TopoOrder(cl, direction); } @@ -9097,6 +9111,7 @@ methodName, cmd, cscPtr);*/ assert(cscPtr->cmdPtr == cmd); Tcl_DeleteCommandFromToken(interp, cmd); + NsfMethodEpochIncr("DeleteObjectAlias"); NsfCleanupObject(invokeObj, "alias-delete1"); return NsfPrintError(interp, "Trying to dispatch deleted object via method '%s'", @@ -9470,6 +9485,8 @@ Tcl_Obj *cmdName = object->cmdName, *methodObj, *cmdObj; NsfCallStackContent csc, *cscPtr = NULL; int validCscPtr = 1; + // TODO: best place? + //NsfCallStackContent *cscPtr1 = CallStackGetTopFrame0(interp); /* none of the higher copy-flags must be passed */ assert((flags & (NSF_CSC_COPY_FLAGS & 0xFFF000)) == 0); @@ -9491,6 +9508,12 @@ } } +#if defined(METHOD_OBJECT_TRACE) + fprintf(stderr, "methodname %s type %p <%s>\n", + methodName, methodObj->typePtr, + methodObj->typePtr ? methodObj->typePtr->name : ""); +#endif + /*fprintf(stderr, "ObjectDispatch obj = %s objc = %d 0=%s methodName=%s shift %d\n", object ? ObjectName(object) : NULL, objc, cmdObj ? ObjStr(cmdObj) : NULL, @@ -9677,15 +9700,36 @@ */ if (likely(cmd == NULL)) { - /* do we have a object-specific proc? */ - if (object->nsPtr && (flags & (NSF_CM_NO_OBJECT_METHOD|NSF_CM_SYSTEM_METHOD)) == 0) { - cmd = FindMethod(object->nsPtr, methodName); - /*fprintf(stderr, "lookup for proc in obj %p method %s nsPtr %p => %p\n", - object, methodName, object->nsPtr, cmd);*/ - if (cmd - && (flags & ( NSF_CM_LOCAL_METHOD|NSF_CM_IGNORE_PERMISSIONS)) == 0 - && (Tcl_Command_flags(cmd) & NSF_CMD_CALL_PRIVATE_METHOD)) { - cmd = NULL; + NsfMethodContext *mcPtr = methodObj->internalRep.twoPtrValue.ptr1; + + if (methodObj->typePtr == &NsfObjectMethodObjType + && mcPtr->context == object + && mcPtr->methodEpoch == nsfMethodEpoch + && mcPtr->flags == flags + ) { + cmd = mcPtr->cmd; + //cl = mcPtr->cl; +#if defined(METHOD_OBJECT_TRACE) + fprintf(stderr, "... reuse object method %p %s cmd %p cl %p %s\n", + methodObj, ObjStr(methodObj), + cmd, cl, cl ? ClassName(cl) : ObjectName(object)); +#endif + } else { + /* do we have an object-specific proc? */ + if (object->nsPtr && (flags & (NSF_CM_NO_OBJECT_METHOD|NSF_CM_SYSTEM_METHOD)) == 0) { + cmd = FindMethod(object->nsPtr, methodName); + /*fprintf(stderr, "lookup for proc in obj %p method %s nsPtr %p => %p\n", + object, methodName, object->nsPtr, cmd);*/ + if (cmd) { + if ((flags & (NSF_CM_LOCAL_METHOD|NSF_CM_IGNORE_PERMISSIONS)) == 0 + && (Tcl_Command_flags(cmd) & NSF_CMD_CALL_PRIVATE_METHOD)) { + cmd = NULL; + } else { + NsfMethodObjSet(interp, methodObj, &NsfObjectMethodObjType, + object, nsfMethodEpoch, + cmd, NULL, flags); + } + } } } #if defined(INHERIT_CLASS_METHODS) @@ -9695,24 +9739,54 @@ cmd = NsfFindClassMethod(interp, (NsfClass *)object, methodName); } #endif - + if (likely(cmd == NULL)) { /* check for a method inherited from a class */ NsfClass *currentClass = object->cl; - if (unlikely(currentClass->order == NULL)) { - currentClass->order = TopoOrder(currentClass, SUPER_CLASSES); - } - if (unlikely(flags & NSF_CM_SYSTEM_METHOD)) { - NsfClasses *classList = currentClass->order; - /* - * Skip entries until the first base class. - */ - for (; classList; classList = classList->nextPtr) { - if (IsBaseClass(classList->cl)) {break;} - } - cl = SearchPLMethod(classList, methodName, &cmd, NSF_CMD_CALL_PRIVATE_METHOD); + NsfMethodContext *mcPtr = methodObj->internalRep.twoPtrValue.ptr1; + +#if defined(METHOD_OBJECT_TRACE) + fprintf(stderr, "... method %p '%s' type? %d context? %d nsfMethodEpoch %d/%d\n", + methodObj, ObjStr(methodObj), + methodObj->typePtr == &NsfInstanceMethodObjType, + methodObj->typePtr == &NsfInstanceMethodObjType ? currentClass : 0, + methodObj->typePtr == &NsfInstanceMethodObjType ? mcPtr->methodEpoch : 0, + nsfMethodEpoch ); +#endif + + if (methodObj->typePtr == &NsfInstanceMethodObjType + && mcPtr->context == currentClass + && mcPtr->methodEpoch == nsfMethodEpoch + && mcPtr->flags == flags + ) { + cmd = mcPtr->cmd; + cl = mcPtr->cl; +#if defined(METHOD_OBJECT_TRACE) + fprintf(stderr, "... reuse instance method %p %s cmd %p cl %p %s\n", + methodObj, ObjStr(methodObj), + cmd, cl, cl ? ClassName(cl) : ObjectName(object)); +#endif } else { - cl = SearchPLMethod(currentClass->order, methodName, &cmd, NSF_CMD_CALL_PRIVATE_METHOD); + + if (unlikely(currentClass->order == NULL)) { + currentClass->order = TopoOrder(currentClass, SUPER_CLASSES); + } + if (unlikely(flags & NSF_CM_SYSTEM_METHOD)) { + NsfClasses *classList = currentClass->order; + /* + * Skip entries until the first base class. + */ + for (; classList; classList = classList->nextPtr) { + if (IsBaseClass(classList->cl)) {break;} + } + cl = SearchPLMethod(classList, methodName, &cmd, NSF_CMD_CALL_PRIVATE_METHOD); + } else { + cl = SearchPLMethod(currentClass->order, methodName, &cmd, NSF_CMD_CALL_PRIVATE_METHOD); + } + + NsfMethodObjSet(interp, methodObj, &NsfInstanceMethodObjType, + currentClass, nsfMethodEpoch, + cmd, cl, flags); } } } @@ -11550,6 +11624,7 @@ #endif } + NsfMethodEpochIncr("MakeMethod"); if (cl) { /* could be a filter or filter inheritance ... update filter orders */ FilterInvalidateObjOrders(interp, cl); @@ -11797,7 +11872,7 @@ /* *---------------------------------------------------------------------- - * NsfAddParameterProc -- + * NsfProcAdd -- * * Add a command for implementing a Tcl proc with next scripting * parameter handling. @@ -11821,7 +11896,7 @@ *---------------------------------------------------------------------- */ static int -NsfAddParameterProc(Tcl_Interp *interp, NsfParsedParam *parsedParamPtr, +NsfProcAdd(Tcl_Interp *interp, NsfParsedParam *parsedParamPtr, CONST char *procName, Tcl_Obj *body, int with_ad) { NsfParamDefs *paramDefs = parsedParamPtr->paramDefs; Tcl_Namespace *cmdNsPtr; @@ -11863,7 +11938,7 @@ cmdNsPtr = Tcl_Command_nsPtr(cmd); ParamDefsStore(cmd, paramDefs); - /*fprintf(stderr, "NsfAddParameterProc procName '%s' define cmd '%s' %p in namespace %s\n", + /*fprintf(stderr, "NsfProcAdd procName '%s' define cmd '%s' %p in namespace %s\n", procName, Tcl_GetCommandName(interp, cmd), cmd, cmdNsPtr->fullName);*/ /* @@ -11899,7 +11974,7 @@ tcd->with_ad = with_ad; tcd->cmd = NULL; - /*fprintf(stderr, "NsfAddParameterProc %s tcd %p paramdefs %p\n", + /*fprintf(stderr, "NsfProcAdd %s tcd %p paramdefs %p\n", ObjStr(procNameObj), tcd, tcd->paramDefs);*/ /* @@ -11938,7 +12013,7 @@ ov[2] = argList; ov[3] = AddPrefixToBody(body, 1, parsedParamPtr); - /*fprintf(stderr, "NsfAddParameterProc define proc %s arglist '%s'\n", + /*fprintf(stderr, "NsfProcAdd define proc %s arglist '%s'\n", ObjStr(ov[1]), ObjStr(ov[2])); */ result = Tcl_ProcObjCmd(0, interp, 4, ov); @@ -13243,6 +13318,7 @@ /*fprintf(stderr, "CleanupDestroyObject obj %p softrecreate %d nsPtr %p\n", object, softrecreate, object->nsPtr);*/ + NsfMethodEpochIncr("CleanupDestroyObject"); /* remove the instance, but not for ::Class/::Object */ if ((object->flags & NSF_IS_ROOT_CLASS) == 0 && @@ -13362,6 +13438,8 @@ /*fprintf(stderr, "****** PrimitiveODestroy %p cmd %p flags %.6x\n", object, object->id, object->flags);*/ + //NsfMethodEpochIncr("PrimitiveODestroy"); + assert(!(object->flags & NSF_DELETED)); /* destroy must have been called already */ @@ -13871,6 +13949,7 @@ Tcl_Namespace *saved; PRINTOBJ("PrimitiveCDestroy", object); + //NsfMethodEpochIncr("PrimitiveCDestroy"); /* * check and latch against recurrent calls with obj->teardown @@ -14015,6 +14094,8 @@ ChangeClass(Tcl_Interp *interp, NsfObject *object, NsfClass *cl) { assert(object); + NsfMethodEpochIncr("ChangeClass"); + /*fprintf(stderr, "changing %s to class %s ismeta %d\n", ObjectName(object), ClassName(cl), IsMetaClass(interp, cl, 1));*/ @@ -19146,7 +19227,7 @@ * is added which handles the parameter passing and calls the proc * later. */ - result = NsfAddParameterProc(interp, &parsedParam, ObjStr(nameObj), body, with_ad); + result = NsfProcAdd(interp, &parsedParam, ObjStr(nameObj), body, with_ad); } else { /* Index: generic/nsf.h =================================================================== diff -u -r24724ebae83af4e0104b349a2fb582bfc71a7475 -r877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac --- generic/nsf.h (.../nsf.h) (revision 24724ebae83af4e0104b349a2fb582bfc71a7475) +++ generic/nsf.h (.../nsf.h) (revision 877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac) @@ -97,6 +97,7 @@ */ //#define PARSE_TRACE 1 //#define PARSE_TRACE_FULL 1 +//#define METHOD_OBJECT_TRACE 1 /* turn tracing output on/off #define NSFOBJ_TRACE 1 Index: generic/nsfInt.h =================================================================== diff -u -r24724ebae83af4e0104b349a2fb582bfc71a7475 -r877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac --- generic/nsfInt.h (.../nsfInt.h) (revision 24724ebae83af4e0104b349a2fb582bfc71a7475) +++ generic/nsfInt.h (.../nsfInt.h) (revision 877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac) @@ -935,7 +935,24 @@ #define NSF_FLAG_DASHDAH 0x01 #define NSF_FLAG_CONTAINS_VALUE 0x02 +/* + * NsfMethodContext type + */ +extern Tcl_ObjType NsfInstanceMethodObjType; +extern Tcl_ObjType NsfObjectMethodObjType; +extern int NsfMethodObjSet(Tcl_Interp *interp, Tcl_Obj *objPtr, + Tcl_ObjType *objectType, + void *context, int methodEpoch, + Tcl_Command cmd, NsfClass *cl, int flags); +typedef struct { + void *context; + int methodEpoch; + Tcl_Command cmd; + NsfClass *cl; + int flags; +} NsfMethodContext; + /* functions from nsfUtil.c */ char *Nsf_ltoa(char *buf, long i, int *len); char *NsfStringIncr(NsfStringIncrStruct *iss); Index: generic/nsfObj.c =================================================================== diff -u -re639a46f30e0e0c10dc84c898e828b9abe9298d9 -r877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac --- generic/nsfObj.c (.../nsfObj.c) (revision e639a46f30e0e0c10dc84c898e828b9abe9298d9) +++ generic/nsfObj.c (.../nsfObj.c) (revision 877c1e7d364b91e0a1d501738dfbb7b9dcb7d5ac) @@ -12,20 +12,132 @@ */ #include "nsfInt.h" +/* + *---------------------------------------------------------------------- + * + * NsfMethodObjType Tcl_Obj type -- + * + * The NsfMethodObjType is an Tcl_Obj type carrying the result of + * a method lookup. We define two types (NsfInstanceMethodObjType + * and NsfObjectMethodObjType) sharing their implementation. The + * type setting function NsfMethodObjSet() receives the intended + * type. + * + *---------------------------------------------------------------------- + */ +static Tcl_FreeInternalRepProc MethodFreeInternalRep; + +Tcl_ObjType NsfInstanceMethodObjType = { + "nsfInstanceMethod", /* name */ + MethodFreeInternalRep, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; +Tcl_ObjType NsfObjectMethodObjType = { + "nsfObjectMethod", /* name */ + MethodFreeInternalRep, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + NULL, /* updateStringProc */ + NULL /* setFromAnyProc */ +}; + +/* + * freeIntRepProc + */ +static void +MethodFreeInternalRep( + register Tcl_Obj *objPtr) /* Tcl_Obj structure object with internal + * representation to free. */ +{ + NsfMethodContext *mcPtr = (NsfMethodContext *)objPtr->internalRep.twoPtrValue.ptr1; + + if (mcPtr != NULL) { + + /*fprintf(stderr, "MethodFreeInternalRep %p flagPtr %p serial (%d) payload %p\n", + objPtr, flagPtr, flagPtr->serial, flagPtr->payload);*/ + + /* + * ... and free structure + */ + FREE(NsfMethodContext, mcPtr); + objPtr->internalRep.twoPtrValue.ptr1 = NULL; // TODO: needed? + } +} + /* *---------------------------------------------------------------------- * - * Mixinreg Tcl_Obj type -- + * NsfMethodObjSet -- * - * The mixin registration type is an Tcl_Obj type carrying a - * class and a guard object. The string representation might have - * the form "/cls/" or "/cls/ -guard /expr/". When no guard - * expression is provided (first form), the guard entry is NULL. + * Convert the provided Tcl_Obj into the type of NsfMethodContext. * *---------------------------------------------------------------------- */ +int +NsfMethodObjSet( + Tcl_Interp *interp, /* Used for error reporting if not NULL. */ + register Tcl_Obj *objPtr, /* The object to convert. */ + Tcl_ObjType *objectType, + void *context, /* context (to avoid over-eager sharing) */ + int methodEpoch, /* methodEpoch */ + Tcl_Command cmd, /* the tclCommand behind the method */ + NsfClass *cl, /* the object/class where the method was defined */ + int flags /* flags */ + ) +{ + NsfMethodContext *mcPtr; +#if defined(METHOD_OBJECT_TRACE) + fprintf(stderr, "... NsfMethodObjSet %p %s context %p methodEpoch %d " + "cmd %p cl %p %s old obj type <%s> flags %.6x\n", + objPtr, ObjStr(objPtr), context, methodEpoch, cmd, cl, cl ? ClassName(cl) : "obj", + objPtr->typePtr ? objPtr->typePtr->name : "none", flags); +#endif + /* + * Free or reuse the old interal representation and store own + * structure as internal representation. + */ + if (likely(objPtr->typePtr != objectType)) { + TclFreeIntRep(objPtr); + mcPtr = NEW(NsfMethodContext); + objPtr->internalRep.twoPtrValue.ptr1 = (void *)mcPtr; + objPtr->internalRep.twoPtrValue.ptr2 = NULL; + objPtr->typePtr = objectType; + } else { + mcPtr = (NsfMethodContext *)objPtr->internalRep.twoPtrValue.ptr1; + + /*fprintf(stderr, "... NsfMethodObjSet %p reuses interal rep, serial (%d/%d)\n", + objPtr, mcPtr->methodEpoch, methodEpoch);*/ + + } + + assert(mcPtr); + + /* + * add values to the structure + */ + mcPtr->context = context; + mcPtr->methodEpoch = methodEpoch; + mcPtr->cmd = cmd; + mcPtr->cl = cl; + mcPtr->flags = flags; + + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * NsfFlagObjType -- + * + * The NsfFlagObjType is an Tcl_Obj type carrying the result of a + * flag lookup. + * + *---------------------------------------------------------------------- + */ + static Tcl_FreeInternalRepProc FlagFreeInternalRep; Tcl_ObjType NsfFlagObjType = {