From 1154dfa4f03f90bf76c0b9b82ed7667cd7ce2bf6 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 22 Aug 2025 17:31:18 +0000 Subject: Rewrite slots in C to get a performance boost. (backport) --- generic/tclOO.c | 12 + generic/tclOODefineCmds.c | 609 ++++++++++++++++++++++++++++++++++++++++++++-- generic/tclOOInt.h | 4 + generic/tclOOScript.h | 55 ----- tools/tclOOScript.tcl | 94 +------ 5 files changed, 604 insertions(+), 170 deletions(-) diff --git a/generic/tclOO.c b/generic/tclOO.c index a4c4da1..563832a 100644 --- a/generic/tclOO.c +++ b/generic/tclOO.c @@ -369,6 +369,10 @@ InitFoundation( TclNewLiteralStringObj(fPtr->defineName, "::oo::define"); TclNewLiteralStringObj(fPtr->myName, "my"); TclNewLiteralStringObj(fPtr->mcdName, "::oo::MixinClassDelegates"); + TclNewLiteralStringObj(fPtr->slotGetName, "Get"); + TclNewLiteralStringObj(fPtr->slotSetName, "Set"); + TclNewLiteralStringObj(fPtr->slotResolveName, "Resolve"); + TclNewLiteralStringObj(fPtr->slotDefOpName, "--default-operation"); Tcl_IncrRefCount(fPtr->unknownMethodNameObj); Tcl_IncrRefCount(fPtr->constructorName); Tcl_IncrRefCount(fPtr->destructorName); @@ -376,6 +380,10 @@ InitFoundation( Tcl_IncrRefCount(fPtr->defineName); Tcl_IncrRefCount(fPtr->myName); Tcl_IncrRefCount(fPtr->mcdName); + Tcl_IncrRefCount(fPtr->slotGetName); + Tcl_IncrRefCount(fPtr->slotSetName); + Tcl_IncrRefCount(fPtr->slotResolveName); + Tcl_IncrRefCount(fPtr->slotDefOpName); TclCreateObjCommandInNs(interp, "UnknownDefinition", fPtr->ooNs, TclOOUnknownDefinition, NULL, NULL); @@ -619,6 +627,10 @@ KillFoundation( TclDecrRefCount(fPtr->defineName); TclDecrRefCount(fPtr->myName); TclDecrRefCount(fPtr->mcdName); + TclDecrRefCount(fPtr->slotGetName); + TclDecrRefCount(fPtr->slotSetName); + TclDecrRefCount(fPtr->slotResolveName); + TclDecrRefCount(fPtr->slotDefOpName); TclOODecrRefCount(fPtr->objectCls->thisPtr); TclOODecrRefCount(fPtr->classCls->thisPtr); diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index 5b6de0e..d9a637a 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -39,15 +39,25 @@ typedef struct DeclaredSlot { const Tcl_MethodType resolverType; } DeclaredSlot; -#define SLOT(name,getter,setter,resolver) \ +#define SLOT(name,getter,setter,resolver) \ {"::oo::" name, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Getter", \ getter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Setter", \ setter, NULL, NULL}, \ - {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Resolver", \ + {TCL_OO_METHOD_VERSION_1, "core method: " name " Resolver", \ resolver, NULL, NULL}} +typedef struct DeclaredSlotMethod { + const char *name; + int flags; + const Tcl_MethodType implType; +} DeclaredSlotMethod; + +#define SLOT_METHOD(name,impl,flags) \ + {name, flags, {TCL_OO_METHOD_VERSION_1, \ + "core method: " name " slot", impl, NULL, NULL}} + /* * A [string match] pattern used to determine if a method should be exported. */ @@ -78,6 +88,33 @@ static inline void RecomputeClassCacheFlag(Object *oPtr); static int RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr, int useClass, Tcl_Obj *const fromPtr, Tcl_Obj *const toPtr); +static int Slot_Append(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_AppendNew(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Clear(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Prepend(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Remove(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Resolve(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Set(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); +static int Slot_Unimplemented(void *, + Tcl_Interp *interp, Tcl_ObjectContext, + int, Tcl_Obj *const *); +static int Slot_Unknown(void *, + Tcl_Interp *interp, Tcl_ObjectContext context, + int objc, Tcl_Obj *const *objv); static int ClassFilter_Get(void *clientData, Tcl_Interp *interp, Tcl_ObjectContext context, int objc, Tcl_Obj *const *objv); @@ -175,6 +212,20 @@ static const DeclaredSlot slots[] = { {NULL, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}, {0, 0, 0, 0, 0}} }; +static const DeclaredSlotMethod slotMethods[] = { + SLOT_METHOD("Get", Slot_Unimplemented, 0), + SLOT_METHOD("Resolve", Slot_Resolve, 0), + SLOT_METHOD("Set", Slot_Unimplemented, 0), + SLOT_METHOD("-append", Slot_Append, PUBLIC_METHOD), + SLOT_METHOD("-appendifnew", Slot_AppendNew, PUBLIC_METHOD), + SLOT_METHOD("-clear", Slot_Clear, PUBLIC_METHOD), + SLOT_METHOD("-prepend", Slot_Prepend, PUBLIC_METHOD), + SLOT_METHOD("-remove", Slot_Remove, PUBLIC_METHOD), + SLOT_METHOD("-set", Slot_Set, PUBLIC_METHOD), + SLOT_METHOD("unknown", Slot_Unknown, 0), + {NULL, 0, {0, 0, 0, 0, 0}} +}; + /* * How to build the in-namespace name of a private variable. This is a pattern * used with Tcl_ObjPrintf(). @@ -2397,50 +2448,560 @@ int TclOODefineSlots( Foundation *fPtr) { - const DeclaredSlot *slotInfoPtr; Tcl_Interp *interp = fPtr->interp; - Tcl_Obj *getName, *setName, *resolveName; Tcl_Object object = Tcl_NewObjectInstance(interp, (Tcl_Class) fPtr->classCls, "::oo::Slot", NULL, TCL_INDEX_NONE, NULL, 0); - Class *slotCls; + Tcl_Class slotCls; + const DeclaredSlotMethod *smPtr; + const DeclaredSlot *slotPtr; if (object == NULL) { return TCL_ERROR; } - slotCls = ((Object *) object)->classPtr; + slotCls = (Tcl_Class) ((Object *) object)->classPtr; if (slotCls == NULL) { return TCL_ERROR; } - TclNewLiteralStringObj(getName, "Get"); - TclNewLiteralStringObj(setName, "Set"); - TclNewLiteralStringObj(resolveName, "Resolve"); - for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) { + for (smPtr = slotMethods; smPtr->name; smPtr++) { + Tcl_Obj *name = Tcl_NewStringObj(smPtr->name, -1); + Tcl_NewMethod(interp, slotCls, name, smPtr->flags, + &smPtr->implType, NULL); + Tcl_BounceRefCount(name); + } + + for (slotPtr = slots ; slotPtr->name ; slotPtr++) { Tcl_Object slotObject = Tcl_NewObjectInstance(interp, - (Tcl_Class) slotCls, slotInfoPtr->name, NULL, TCL_INDEX_NONE, - NULL, 0); + slotCls, slotPtr->name, NULL, TCL_INDEX_NONE, NULL, 0); if (slotObject == NULL) { continue; } - TclNewInstanceMethod(interp, slotObject, getName, 0, - &slotInfoPtr->getterType, NULL); - TclNewInstanceMethod(interp, slotObject, setName, 0, - &slotInfoPtr->setterType, NULL); - if (slotInfoPtr->resolverType.callProc) { - TclNewInstanceMethod(interp, slotObject, resolveName, 0, - &slotInfoPtr->resolverType, NULL); + TclNewInstanceMethod(interp, slotObject, fPtr->slotGetName, 0, + &slotPtr->getterType, NULL); + TclNewInstanceMethod(interp, slotObject, fPtr->slotSetName, 0, + &slotPtr->setterType, NULL); + if (slotPtr->resolverType.callProc) { + TclNewInstanceMethod(interp, slotObject, fPtr->slotResolveName, 0, + &slotPtr->resolverType, NULL); + } + } + return TCL_OK; +} + +/* + * ---------------------------------------------------------------------- + * + * CallSlotGet, CallSlotSet, CallSlotResolve, ResolveAll -- + * + * How to call the standard low-level methods of a slot. + * ResolveAll is the lifting of CallSlotResolve to work over a whole + * list of items. + * + * ---------------------------------------------------------------------- + */ + +// Call [$slot Get] to retrieve the list of contents of the slot +static inline Tcl_Obj * +CallSlotGet( + Tcl_Interp *interp, + Object *slot) +{ + Tcl_Obj *getArgs[2]; + int code; + + getArgs[0] = slot->fPtr->myName; + getArgs[1] = slot->fPtr->slotGetName; + code = TclOOPrivateObjectCmd(slot, interp, 2, getArgs); + if (code != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +// Call [$slot Set $list] to set the list of contents of the slot +static inline int +CallSlotSet( + Tcl_Interp *interp, + Object *slot, + Tcl_Obj *list) +{ + Tcl_Obj *setArgs[3]; + setArgs[0] = slot->fPtr->myName; + setArgs[1] = slot->fPtr->slotSetName; + setArgs[2] = list; + return TclOOPrivateObjectCmd(slot, interp, 3, setArgs); +} + +// Call [$slot Resolve $item] to convert a slot item into canonical form +static inline Tcl_Obj * +CallSlotResolve( + Tcl_Interp *interp, + Object *slot, + Tcl_Obj *item) +{ + Tcl_Obj *resolveArgs[3]; + int code; + + resolveArgs[0] = slot->fPtr->myName; + resolveArgs[1] = slot->fPtr->slotResolveName; + resolveArgs[2] = item; + code = TclOOPrivateObjectCmd(slot, interp, 3, resolveArgs); + if (code != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +static inline Tcl_Obj * +ResolveAll( + Tcl_Interp *interp, + Object *slot, + int objc, + Tcl_Obj *const *objv) +{ + Tcl_Obj **resolvedItems = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * objc); + Tcl_Obj *resolvedList; + int i; + + for (i = 0; i < objc; i++) { + resolvedItems[i] = CallSlotResolve(interp, slot, objv[i]); + if (resolvedItems[i] == NULL) { + for (int j = 0; j < i; j++) { + Tcl_DecrRefCount(resolvedItems[j]); + } + TclStackFree(interp, (void *) resolvedItems); + return NULL; + } + Tcl_IncrRefCount(resolvedItems[i]); + Tcl_ResetResult(interp); + } + resolvedList = Tcl_NewListObj(objc, resolvedItems); + for (i = 0; i < objc; i++) { + TclDecrRefCount(resolvedItems[i]); + } + TclStackFree(interp, (void *) resolvedItems); + return resolvedList; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_Append -- + * + * Implementation of the "-append" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_Append( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context), code; + Tcl_Obj *resolved, *list; + + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; + } + + // Get slot contents; store in list + list = CallSlotGet(interp, oPtr); + if (list == NULL) { + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_IncrRefCount(list); + Tcl_ResetResult(interp); + + // Append + if (Tcl_IsShared(list)) { + Tcl_Obj *dup = Tcl_DuplicateObj(list); + Tcl_IncrRefCount(dup); + Tcl_DecrRefCount(list); + list = dup; + } + if (Tcl_ListObjAppendList(interp, list, resolved) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_DecrRefCount(resolved); + + // Set slot contents + code = CallSlotSet(interp, oPtr, list); + Tcl_DecrRefCount(list); + return code; +} + +/* + * ---------------------------------------------------------------------- + * + * Slot_AppendNew -- + * + * Implementation of the "-appendifnew" slot operation. + * + * ---------------------------------------------------------------------- + */ +static int +Slot_AppendNew( + TCL_UNUSED(void *), + Tcl_Interp *interp, + Tcl_ObjectContext context, + int objc, + Tcl_Obj *const *objv) +{ + Object *oPtr = (Object *) Tcl_ObjectContextObject(context); + int skip = Tcl_ObjectContextSkippedArgs(context), code; + Tcl_Obj *resolved, *list, **listv; + Tcl_Size listc, i; + Tcl_HashTable unique; + + if (skip == objc) { + return TCL_OK; + } + + // Resolve all values + resolved = ResolveAll(interp, oPtr, objc - skip, objv + skip); + if (resolved == NULL) { + return TCL_ERROR; + } + + // Get slot contents; store in list + list = CallSlotGet(interp, oPtr); + if (list == NULL) { + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_IncrRefCount(list); + Tcl_ResetResult(interp); + + // Prepare a set of items in the list to set + if (TclListObjGetElements(interp, list, &listc, &listv) != TCL_OK) { + Tcl_DecrRefCount(list); + Tcl_DecrRefCount(resolved); + return TCL_ERROR; + } + Tcl_InitObjHashTable(&unique); + for (i=0 ; i= objc) { + Tcl_Obj *args[2]; + args[0] = oPtr->fPtr->myName; + args[1] = oPtr->fPtr->slotDefOpName; + return TclOOPrivateObjectCmd(oPtr, interp, 2, args); + } else if (TclGetString(objv[skip])[0] != '-') { + Tcl_Obj **args = (Tcl_Obj **) TclStackAlloc(interp, + sizeof(Tcl_Obj *) * (objc - skip + 2)); + args[0] = oPtr->fPtr->myName; + args[1] = oPtr->fPtr->slotDefOpName; + memcpy(args+2, objv+skip, sizeof(Tcl_Obj*) * (objc - skip)); + code = TclOOPrivateObjectCmd(oPtr, interp, objc - skip + 2, args); + TclStackFree(interp, args); + return code; + } + return TclNRObjectContextInvokeNext(interp, context, objc, objv, skip); +} + +/* + * ---------------------------------------------------------------------- + * * ClassFilter_Get, ClassFilter_Set -- * * Implementation of the "filter" slot accessors of the "oo::define" diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h index 59a0cb6..bd11638 100644 --- a/generic/tclOOInt.h +++ b/generic/tclOOInt.h @@ -407,6 +407,10 @@ struct Foundation { Tcl_Obj *myName; /* The "my" shared object. */ Tcl_Obj *mcdName; /* The shared object for calling the helper to * mix in class delegates. */ + Tcl_Obj *slotGetName; /* The "Get" name used by slots. */ + Tcl_Obj *slotSetName; /* The "Set" name used by slots. */ + Tcl_Obj *slotResolveName; /* The "Resolve" name used by slots. */ + Tcl_Obj *slotDefOpName; /* The "--default-operation" name used by slots. */ }; /* diff --git a/generic/tclOOScript.h b/generic/tclOOScript.h index a9b262c..80c4c68 100644 --- a/generic/tclOOScript.h +++ b/generic/tclOOScript.h @@ -117,62 +117,7 @@ static const char *tclOOSetupScript = "\t\t::tailcall forward $name myclass $name\n" "\t}\n" "\tdefine Slot {\n" -"\t\tmethod Get -unexport {} {\n" -"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Set -unexport list {\n" -"\t\t\treturn -code error -errorcode {TCL OO ABSTRACT_SLOT} \"unimplemented\"\n" -"\t\t}\n" -"\t\tmethod Resolve -unexport list {\n" -"\t\t\treturn $list\n" -"\t\t}\n" -"\t\tmethod -set -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\ttailcall my Set $args\n" -"\t\t}\n" -"\t\tmethod -append -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$current {*}$args]\n" -"\t\t}\n" -"\t\tmethod -appendifnew -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\tforeach a $args {\n" -"\t\t\t\tset a [uplevel 1 [list $my Resolve $a]]\n" -"\t\t\t\tif {$a ni $current} {\n" -"\t\t\t\t\tlappend current $a\n" -"\t\t\t\t}\n" -"\t\t\t}\n" -"\t\t\ttailcall my Set $current\n" -"\t\t}\n" -"\t\tmethod -clear -export {} {tailcall my Set {}}\n" -"\t\tmethod -prepend -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [list {*}$args {*}$current]\n" -"\t\t}\n" -"\t\tmethod -remove -export args {\n" -"\t\t\tset my [namespace which my]\n" -"\t\t\tset args [lmap a $args {uplevel 1 [list $my Resolve $a]}]\n" -"\t\t\tset current [uplevel 1 [list $my Get]]\n" -"\t\t\ttailcall my Set [lmap val $current {\n" -"\t\t\t\tif {$val in $args} continue else {set val}\n" -"\t\t\t}]\n" -"\t\t}\n" "\t\tforward --default-operation my -append\n" -"\t\tmethod unknown -unexport {args} {\n" -"\t\t\tset def --default-operation\n" -"\t\t\tif {[llength $args] == 0} {\n" -"\t\t\t\ttailcall my $def\n" -"\t\t\t} elseif {![string match -* [lindex $args 0]]} {\n" -"\t\t\t\ttailcall my $def {*}$args\n" -"\t\t\t}\n" -"\t\t\tnext {*}$args\n" -"\t\t}\n" "\t\tunexport destroy\n" "\t}\n" "\tobjdefine define::superclass forward --default-operation my -set\n" diff --git a/tools/tclOOScript.tcl b/tools/tclOOScript.tcl index 542b711..e829fcf 100644 --- a/tools/tclOOScript.tcl +++ b/tools/tclOOScript.tcl @@ -198,103 +198,15 @@ define Slot { # ------------------------------------------------------------------ # - # Slot Get -- + # Slot --default-operation -- # - # Basic slot getter. Retrieves the contents of the slot. - # Particular slots must provide concrete non-erroring - # implementation. + # If a slot can't figure out what method to call directly, it + # uses --default-operation. # # ------------------------------------------------------------------ - method Get -unexport {} { - return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented" - } - - # ------------------------------------------------------------------ - # - # Slot Set -- - # - # Basic slot setter. Sets the contents of the slot. Particular - # slots must provide concrete non-erroring implementation. - # - # ------------------------------------------------------------------ - - method Set -unexport list { - return -code error -errorcode {TCL OO ABSTRACT_SLOT} "unimplemented" - } - - # ------------------------------------------------------------------ - # - # Slot Resolve -- - # - # Helper that lets a slot convert a list of arguments of a - # particular type to their canonical forms. Defaults to doing - # nothing (suitable for simple strings). - # - # ------------------------------------------------------------------ - - method Resolve -unexport list { - return $list - } - - # ------------------------------------------------------------------ - # - # Slot -set, -append, -clear, --default-operation -- - # - # Standard public slot operations. If a slot can't figure out - # what method to call directly, it uses --default-operation. - # - # ------------------------------------------------------------------ - - method -set -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - tailcall my Set $args - } - method -append -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [list {*}$current {*}$args] - } - method -appendifnew -export args { - set my [namespace which my] - set current [uplevel 1 [list $my Get]] - foreach a $args { - set a [uplevel 1 [list $my Resolve $a]] - if {$a ni $current} { - lappend current $a - } - } - tailcall my Set $current - } - method -clear -export {} {tailcall my Set {}} - method -prepend -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [list {*}$args {*}$current] - } - method -remove -export args { - set my [namespace which my] - set args [lmap a $args {uplevel 1 [list $my Resolve $a]}] - set current [uplevel 1 [list $my Get]] - tailcall my Set [lmap val $current { - if {$val in $args} continue else {set val} - }] - } - # Default handling forward --default-operation my -append - method unknown -unexport {args} { - set def --default-operation - if {[llength $args] == 0} { - tailcall my $def - } elseif {![string match -* [lindex $args 0]]} { - tailcall my $def {*}$args - } - next {*}$args - } # Hide destroy unexport destroy -- cgit v0.12