[Patch #424851]: Faster array searching & obj cleanup

6 files changed, 145 insertions, 50 deletions

diff --git a/ChangeLog b/ChangeLog
index 0ec5cd5..f15e7fb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,18 @@
+2001-05-17  Donal K. Fellows  <fellowsd@cs.man.ac.uk>
+
+	* generic/tclVar.c (tclArraySearchType,SetArraySearchObj,
+	ParseSearchId): Added code to speed up array searching by reducing
+	the amount of parsing needed for searchIds.
+
+	* generic/tclObj.c (TclInitObjSubsystem): 
+	* generic/tclIndexObj.c (Tcl_GetIndexFromObjStruct): 
+	* generic/tclNamesp.c (TclInitNamespaceSubsystem): 
+	* generic/tclInt.h: Moved some Tcl_ObjType initialisation to
+	TclInitObjSubsystem to be with the bulk of the rest.
+	[Patch 
+	Committed by Miguel Sofer <msofer@users.sourceforge.net>
+
+
 2001-05-23  Jeff Hobbs  <jeffh@ActiveState.com>
 
 	* tests/io.test: changed io-52.[9-11] to not be platform sensitive
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 1ae0d8c..3c491dd 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclIndexObj.c,v 1.8 2000/11/24 11:27:37 dkf Exp $
+ * RCS: @(#) $Id: tclIndexObj.c,v 1.9 2001/05/26 01:25:59 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -44,13 +44,6 @@ Tcl_ObjType tclIndexType = {
  * with a single offset, but this is a pretty safe assumption in
  * practise...
  */
-
-/*
- * Boolean flag indicating whether or not the tclIndexType object
- * type has been registered with the Tcl compiler.
- */
-
-static int indexTypeInitialized = 0;
 
 /*
  *----------------------------------------------------------------------
@@ -171,16 +164,6 @@ Tcl_GetIndexFromObjStruct(interp, objPtr, tablePtr, offset, msg, flags,
      * abbreviations unless TCL_EXACT is set in flags.
      */
 
-    if (!indexTypeInitialized) {
-	/*
-	 * This is the first time we've done a lookup.  Register the
-	 * tclIndexType.
-	 */
-
-        Tcl_RegisterObjType(&tclIndexType);
-        indexTypeInitialized = 1;
-    }
-
     key = Tcl_GetStringFromObj(objPtr, &length);
     index = -1;
     numAbbrev = 0;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index cb7646b..e0ded8b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.54 2001/05/17 02:13:03 hobbs Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.55 2001/05/26 01:25:59 msofer Exp $
  */
 
 #ifndef _TCLINT
@@ -1592,6 +1592,9 @@ extern Tcl_ObjType	tclIntType;
 extern Tcl_ObjType	tclListType;
 extern Tcl_ObjType	tclProcBodyType;
 extern Tcl_ObjType	tclStringType;
+extern Tcl_ObjType	tclArraySearchType;
+extern Tcl_ObjType	tclIndexType;
+extern Tcl_ObjType	tclNsNameType;
 
 /*
  * Variables denoting the hash key types defined in the core.
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 577a139..e570c24 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -19,7 +19,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.23 2001/05/15 14:19:13 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.24 2001/05/26 01:25:59 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -166,7 +166,7 @@ Tcl_ObjType tclNsNameType = {
  *	None.
  *
  * Side effects:
- *	The namespace object type is registered with the Tcl compiler.
+ *	None.
  *
  *----------------------------------------------------------------------
  */
@@ -174,7 +174,9 @@ Tcl_ObjType tclNsNameType = {
 void
 TclInitNamespaceSubsystem()
 {
-    Tcl_RegisterObjType(&tclNsNameType);
+    /*
+     * Does nothing for now.
+     */
 }
 
 /*
diff --git a/generic/tclObj.c b/generic/tclObj.c
index cd2cd7a..21a4caf 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -11,7 +11,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclObj.c,v 1.21 2001/05/23 06:05:44 hobbs Exp $
+ * RCS: @(#) $Id: tclObj.c,v 1.22 2001/05/26 01:25:59 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -155,6 +155,9 @@ TclInitObjSubsystem()
     Tcl_RegisterObjType(&tclListType);
     Tcl_RegisterObjType(&tclByteCodeType);
     Tcl_RegisterObjType(&tclProcBodyType);
+    Tcl_RegisterObjType(&tclArraySearchType);
+    Tcl_RegisterObjType(&tclIndexType);
+    Tcl_RegisterObjType(&tclNsNameType);
 
 #ifdef TCL_COMPILE_STATS
     Tcl_MutexLock(&tclObjMutex);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 4f31613..f206224 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.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: tclVar.c,v 1.32 2001/05/17 02:13:03 hobbs Exp $
+ * RCS: @(#) $Id: tclVar.c,v 1.33 2001/05/26 01:25:59 msofer Exp $
  */
 
 #include "tclInt.h"
@@ -53,10 +53,29 @@ static int		MakeUpvar _ANSI_ARGS_((
 			    char *myName, int myFlags));
 static Var *		NewVar _ANSI_ARGS_((void));
 static ArraySearch *	ParseSearchId _ANSI_ARGS_((Tcl_Interp *interp,
-			    Var *varPtr, char *varName, char *string));
+			    Var *varPtr, char *varName, Tcl_Obj *handleObj));
 static void		VarErrMsg _ANSI_ARGS_((Tcl_Interp *interp,
 			    char *part1, char *part2, char *operation,
 			    char *reason));
+static int		SetArraySearchObj _ANSI_ARGS_((Tcl_Interp *interp,
+			    Tcl_Obj *objPtr));
+
+/*
+ * Type of Tcl_Objs used to speed up array searches.
+ *
+ * INTERNALREP DEFINITION:
+ *   twoPtrValue.ptr1 = searchIdNumber as offset from (char*)NULL
+ *   twoPtrValue.ptr2 = variableNameStartInString as offset from (char*)NULL
+ *
+ * Note that the value stored in ptr2 is the offset into the string of
+ * the start of the variable name and not the address of the variable
+ * name itself, as this can be safely copied.
+ */
+Tcl_ObjType tclArraySearchType = {
+    "array search",
+    NULL, NULL, NULL, SetArraySearchObj
+};
+
 
 /*
  *----------------------------------------------------------------------
@@ -3034,7 +3053,6 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
     switch (index) {
         case ARRAY_ANYMORE: {
 	    ArraySearch *searchPtr;
-	    char *searchId;
 	    
 	    if (objc != 4) {
 	        Tcl_WrongNumArgs(interp, 2, objv, 
@@ -3044,8 +3062,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
 	    if (notArray) {
 	        goto error;
 	    }
-	    searchId = Tcl_GetString(objv[3]);
-	    searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+	    searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
 	    if (searchPtr == NULL) {
 	        return TCL_ERROR;
 	    }
@@ -3069,7 +3086,6 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
 	}
         case ARRAY_DONESEARCH: {
 	    ArraySearch *searchPtr, *prevPtr;
-	    char *searchId;
 
 	    if (objc != 4) {
 	        Tcl_WrongNumArgs(interp, 2, objv, 
@@ -3079,8 +3095,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
 	    if (notArray) {
 	        goto error;
 	    }
-	    searchId = Tcl_GetString(objv[3]);
-	    searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+	    searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
 	    if (searchPtr == NULL) {
 	        return TCL_ERROR;
 	    }
@@ -3227,7 +3242,6 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
 	}
         case ARRAY_NEXTELEMENT: {
 	    ArraySearch *searchPtr;
-	    char *searchId;
 	    Tcl_HashEntry *hPtr;
 	    
 	    if (objc != 4) {
@@ -3238,8 +3252,7 @@ Tcl_ArrayObjCmd(dummy, interp, objc, objv)
 	    if (notArray) {
   	        goto error;
 	    }
-	    searchId = Tcl_GetString(objv[3]);
-	    searchPtr = ParseSearchId(interp, varPtr, varName, searchId);
+	    searchPtr = ParseSearchId(interp, varPtr, varName, objv[3]);
 	    if (searchPtr == NULL) {
 	        return TCL_ERROR;
 	    }
@@ -4400,9 +4413,75 @@ NewVar()
 /*
  *----------------------------------------------------------------------
  *
+ * SetArraySearchObj --
+ *
+ *	This function converts the given tcl object into one that
+ *	has the "array search" internal type.
+ *
+ * Results:
+ *	TCL_OK if the conversion succeeded, and TCL_ERROR if it failed
+ *	(when an error message will be placed in the interpreter's
+ *	result.)
+ *
+ * Side effects:
+ *	Updates the internal type and representation of the object to
+ *	make this an array-search object.  See the tclArraySearchType
+ *	declaration above for details of the internal representation.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetArraySearchObj(interp, objPtr)
+    Tcl_Interp *interp;
+    Tcl_Obj *objPtr;
+{
+    char *string;
+    char *end;
+    int id;
+    size_t offset;
+
+    /*
+     * Get the string representation. Make it up-to-date if necessary.
+     */
+
+    string = Tcl_GetString(objPtr);
+
+    /*
+     * Parse the id into the three parts separated by dashes.
+     */
+    if ((string[0] != 's') || (string[1] != '-')) {
+	syntax:
+	Tcl_AppendResult(interp, "illegal search identifier \"", string,
+		"\"", (char *) NULL);
+	return TCL_ERROR;
+    }
+    id = strtoul(string+2, &end, 10);
+    if ((end == (string+2)) || (*end != '-')) {
+	goto syntax;
+    }
+    /*
+     * Can't perform value check in this context, so place reference
+     * to place in string to use for the check in the object instead.
+     */
+    end++;
+    offset = end - string;
+
+    if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
+	objPtr->typePtr->freeIntRepProc(objPtr);
+    }
+    objPtr->typePtr = &tclArraySearchType;
+    objPtr->internalRep.twoPtrValue.ptr1 = (VOID *)(((char *)NULL)+id);
+    objPtr->internalRep.twoPtrValue.ptr2 = (VOID *)(((char *)NULL)+offset);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * ParseSearchId --
  *
- *	This procedure translates from a string to a pointer to an
+ *	This procedure translates from a tcl object to a pointer to an
  *	active array search (if there is one that matches the string).
  *
  * Results:
@@ -4411,41 +4490,47 @@ NewVar()
  *	the interp's result contains an error message.
  *
  * Side effects:
- *	None.
+ *	The tcl object might have its internal type and representation
+ *	modified.
  *
  *----------------------------------------------------------------------
  */
 
 static ArraySearch *
-ParseSearchId(interp, varPtr, varName, string)
+ParseSearchId(interp, varPtr, varName, handleObj)
     Tcl_Interp *interp;		/* Interpreter containing variable. */
     Var *varPtr;		/* Array variable search is for. */
     char *varName;		/* Name of array variable that search is
 				 * supposed to be for. */
-    char *string;		/* String containing id of search. Must have
+    Tcl_Obj *handleObj;		/* Object containing id of search. Must have
 				 * form "search-num-var" where "num" is a
 				 * decimal number and "var" is a variable
 				 * name. */
 {
-    char *end;
+    register char *string;
+    register size_t offset;
     int id;
     ArraySearch *searchPtr;
 
     /*
-     * Parse the id into the three parts separated by dashes.
+     * Parse the id.
      */
-
-    if ((string[0] != 's') || (string[1] != '-')) {
-	syntax:
-	Tcl_AppendResult(interp, "illegal search identifier \"", string,
-		"\"", (char *) NULL);
+    if (Tcl_ConvertToType(interp, handleObj, &tclArraySearchType) != TCL_OK) {
 	return NULL;
     }
-    id = strtoul(string+2, &end, 10);
-    if ((end == (string+2)) || (*end != '-')) {
-	goto syntax;
-    }
-    if (strcmp(end+1, varName) != 0) {
+    /*
+     * Cast is safe, since always came from an int in the first place.
+     */
+    id = (int)(((char*)handleObj->internalRep.twoPtrValue.ptr1) -
+	       ((char*)NULL));
+    string = Tcl_GetString(handleObj);
+    offset = (((char*)handleObj->internalRep.twoPtrValue.ptr2) -
+	      ((char*)NULL));
+    /*
+     * This test cannot be placed inside the Tcl_Obj machinery, since
+     * it is dependent on the variable context.
+     */
+    if (strcmp(string+offset, varName) != 0) {
 	Tcl_AppendResult(interp, "search identifier \"", string,
 		"\" isn't for variable \"", varName, "\"", (char *) NULL);
 	return NULL;
@@ -4454,6 +4539,10 @@ ParseSearchId(interp, varPtr, varName, string)
     /*
      * Search through the list of active searches on the interpreter
      * to see if the desired one exists.
+     *
+     * Note that we cannot store the searchPtr directly in the Tcl_Obj
+     * as that would run into trouble when DeleteSearches() was called
+     * so we must scan this list every time.
      */
 
     for (searchPtr = varPtr->searchPtr; searchPtr != NULL;