TIP#138 implementation plus extra test stuff [Patch 731356]

7 files changed, 170 insertions, 41 deletions

diff --git a/ChangeLog b/ChangeLog
index f0f975c..67e8750 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,11 @@
 2003-11-14  Donal K. Fellows  <donal.k.fellows@man.ac.uk>
 
+	* generic/tclHash.c (Tcl_DeleteHashTable,Tcl_HashStats,RebuildTable): 
+	* generic/tclTest.c (TestHashSystemHashCmd): TIP#138 implementation, 
+	* tests/misc.test:	plus a new chunk of stuff to test the hash
+				functions more thoroughly in the test
+				suite. [Patch 731356, modified] 
+
 	* doc/Tcl.n: Updated Tcl version number and changebars.
 
 2003-11-14  Don Porter	<dgp@users.sourceforge.net>
diff --git a/doc/Hash.3 b/doc/Hash.3
index 3d3e955..1067db5 100644
--- a/doc/Hash.3
+++ b/doc/Hash.3
@@ -5,7 +5,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: Hash.3,v 1.11 2003/07/18 16:56:41 dgp Exp $
+'\" RCS: @(#) $Id: Hash.3,v 1.12 2003/11/14 23:21:02 dkf Exp $
 '\" 
 .so man.macros
 .TH Tcl_Hash 3 "" Tcl "Tcl Library Procedures"
@@ -256,6 +256,17 @@ There are some things, pointers for example which don't hash well
 because they do not use the lower bits. If this flag is set then the
 hash table will attempt to rectify this by randomising the bits and 
 then using the upper N bits as the index into the table.
+.VS 8.5 br
+.IP \fBTCL_HASH_KEY_SYSTEM_HASH\fR 25
+This flag forces Tcl to use the memory allocation 
+procedures provided by the operating system when allocating
+and freeing memory used to store the hash table data structures,
+and not any of Tcl's own customized memory allocation routines.
+This is important if the hash table is to be used in the
+implementation of a custom set of allocation routines, or something
+that a custom set of allocation routines might depend on, in
+order to avoid any circular dependency.
+.VE 8.5
 .PP
 The \fIhashKeyProc\fR member contains the address of a function 
 called to calculate a hash value for the key.
diff --git a/generic/tcl.h b/generic/tcl.h
index 7a9a7dd..8ac310e 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -13,7 +13,7 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tcl.h,v 1.167 2003/11/14 20:44:44 dgp Exp $
+ * RCS: @(#) $Id: tcl.h,v 1.168 2003/11/14 23:21:02 dkf Exp $
  */
 
 #ifndef _TCL
@@ -1169,8 +1169,13 @@ struct Tcl_HashEntry {
  *				hash table will attempt to rectify this by
  *				randomising the bits and then using the upper
  *				N bits as the index into the table.
+ * TCL_HASH_KEY_SYSTEM_HASH:
+ *				If this flag is set then all memory internally
+ *                              allocated for the hash table that is not for an
+ *                              entry will use the system heap.
  */
 #define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
+#define TCL_HASH_KEY_SYSTEM_HASH    0x2
 
 /*
  * Structure definition for the methods associated with a hash table
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 9d63ffc..483f684 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -10,10 +10,11 @@
  * See the file "license.terms" for information on usage and redistribution
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclHash.c,v 1.13 2003/06/24 19:56:12 dkf Exp $
+ * RCS: @(#) $Id: tclHash.c,v 1.14 2003/11/14 23:21:02 dkf Exp $
  */
 
 #include "tclInt.h"
+#include "tclPort.h"
 
 /*
  * Prevent macros from clashing with function definitions.
@@ -626,8 +627,12 @@ Tcl_DeleteHashTable(tablePtr)
      */
 
     if (tablePtr->buckets != tablePtr->staticBuckets) {
+        if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
+	    TclpSysFree((char *) tablePtr->buckets);
+        } else {
 	ckfree((char *) tablePtr->buckets);
     }
+    }
 
     /*
      * Arrange for panics if the table is used again without
@@ -745,6 +750,26 @@ Tcl_HashStats(tablePtr)
     double average, tmp;
     register Tcl_HashEntry *hPtr;
     char *result, *p;
+    Tcl_HashKeyType *typePtr;
+
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+    if (tablePtr->keyType == TCL_STRING_KEYS) {
+	typePtr = &tclStringHashKeyType;
+    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+	typePtr = &tclOneWordHashKeyType;
+    } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+	       || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+	typePtr = tablePtr->typePtr;
+    } else {
+	typePtr = &tclArrayHashKeyType;
+    }
+#else
+    typePtr = tablePtr->typePtr;
+    if (typePtr == NULL) {
+	Tcl_Panic("called Tcl_HashStats on deleted table");
+	return NULL;
+    }
+#endif
 
     /*
      * Compute a histogram of bucket usage.
@@ -774,8 +799,11 @@ Tcl_HashStats(tablePtr)
     /*
      * Print out the histogram and a few other pieces of information.
      */
-
+    if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
+        result = (char *) TclpSysAlloc((unsigned) ((NUM_COUNTERS*60) + 300), 0);
+    } else {
     result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
+    }
     sprintf(result, "%d entries in table, %d buckets\n",
 	    tablePtr->numEntries, tablePtr->numBuckets);
     p = result + strlen(result);
@@ -1122,6 +1150,21 @@ RebuildTable(tablePtr)
     Tcl_HashKeyType *typePtr;
     VOID *key;
 
+#if TCL_PRESERVE_BINARY_COMPATABILITY
+    if (tablePtr->keyType == TCL_STRING_KEYS) {
+	typePtr = &tclStringHashKeyType;
+    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
+	typePtr = &tclOneWordHashKeyType;
+    } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
+	       || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
+	typePtr = tablePtr->typePtr;
+    } else {
+	typePtr = &tclArrayHashKeyType;
+    }
+#else
+    typePtr = tablePtr->typePtr;
+#endif
+
     oldSize = tablePtr->numBuckets;
     oldBuckets = tablePtr->buckets;
 
@@ -1131,8 +1174,13 @@ RebuildTable(tablePtr)
      */
 
     tablePtr->numBuckets *= 4;
+    if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
+        tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned)
+    	        (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0);
+    } else {
     tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned)
 	    (tablePtr->numBuckets * sizeof(Tcl_HashEntry *)));
+    }
     for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
 	    count > 0; count--, newChainPtr++) {
 	*newChainPtr = NULL;
@@ -1141,21 +1189,6 @@ RebuildTable(tablePtr)
     tablePtr->downShift -= 2;
     tablePtr->mask = (tablePtr->mask << 2) + 3;
 
-#if TCL_PRESERVE_BINARY_COMPATABILITY
-    if (tablePtr->keyType == TCL_STRING_KEYS) {
-	typePtr = &tclStringHashKeyType;
-    } else if (tablePtr->keyType == TCL_ONE_WORD_KEYS) {
-	typePtr = &tclOneWordHashKeyType;
-    } else if (tablePtr->keyType == TCL_CUSTOM_TYPE_KEYS
-	       || tablePtr->keyType == TCL_CUSTOM_PTR_KEYS) {
-	typePtr = tablePtr->typePtr;
-    } else {
-	typePtr = &tclArrayHashKeyType;
-    }
-#else
-    typePtr = tablePtr->typePtr;
-#endif
-
     /*
      * Rehash all of the existing entries into the new bucket array.
      */
@@ -1200,6 +1233,10 @@ RebuildTable(tablePtr)
      */
 
     if (oldBuckets != tablePtr->staticBuckets) {
+        if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
+	    TclpSysFree((char *) oldBuckets);
+        } else {
 	ckfree((char *) oldBuckets);
+        }
     }
 }
diff --git a/generic/tclTest.c b/generic/tclTest.c
index c9ff8cb..bfc0481 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.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: tclTest.c,v 1.70 2003/11/14 20:44:45 dgp Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.71 2003/11/14 23:21:02 dkf Exp $
  */
 
 #define TCL_TEST
@@ -423,6 +423,9 @@ static Tcl_Obj*         SimpleCopy _ANSI_ARGS_ ((Tcl_Obj *pathPtr));
 static int              TestNumUtfCharsCmd _ANSI_ARGS_((ClientData clientData,
                             Tcl_Interp *interp, int objc,
 			    Tcl_Obj *CONST objv[]));
+static int              TestHashSystemHashCmd _ANSI_ARGS_((ClientData clientData,
+                            Tcl_Interp *interp, int objc,
+			    Tcl_Obj *CONST objv[]));
 
 static Tcl_Filesystem testReportingFilesystem = {
     "reporting",
@@ -620,6 +623,9 @@ Tcltest_Init(interp)
             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateObjCommand(interp, "testfile", TestfileCmd,
             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
+    Tcl_CreateObjCommand(interp, "testhashsystemhash",
+	    TestHashSystemHashCmd, (ClientData) 0, 
+	    (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateCommand(interp, "testgetassocdata", TestgetassocdataCmd,
             (ClientData) 0, (Tcl_CmdDeleteProc *) NULL);
     Tcl_CreateCommand(interp, "testgetplatform", TestgetplatformCmd,
@@ -6449,3 +6455,78 @@ TestNumUtfCharsCmd(clientData, interp, objc, objv)
     }
     return TCL_OK;
 }
+
+/*
+ * Used to do basic checks of the TCL_HASH_KEY_SYSTEM_HASH flag
+ */
+static int
+TestHashSystemHashCmd(clientData, interp, objc, objv)
+    ClientData clientData;
+    Tcl_Interp *interp;
+    int objc;
+    Tcl_Obj *CONST objv[];
+{
+    static const Tcl_HashKeyType hkType = {
+	TCL_HASH_KEY_TYPE_VERSION, TCL_HASH_KEY_SYSTEM_HASH,
+	NULL, NULL, NULL, NULL
+    };
+    Tcl_HashTable hash;
+    Tcl_HashEntry *hPtr;
+    int i, isNew, limit = 100;
+
+    if (objc>1 && Tcl_GetIntFromObj(interp, objv[1], &limit)!=TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    Tcl_InitCustomHashTable(&hash, TCL_CUSTOM_TYPE_KEYS, &hkType);
+
+    if (hash.numEntries != 0) {
+	Tcl_AppendResult(interp, "non-zero initial size", NULL);
+	Tcl_DeleteHashTable(&hash);
+	return TCL_ERROR;
+    }
+
+    for (i=0 ; i<limit ; i++) {
+	hPtr = Tcl_CreateHashEntry(&hash, (char *)i, &isNew);
+	if (!isNew) {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," creation problem",-1);
+	    Tcl_DeleteHashTable(&hash);
+	    return TCL_ERROR;
+	}
+	Tcl_SetHashValue(hPtr, (ClientData) (i+42));
+    }
+
+    if (hash.numEntries != limit) {
+	Tcl_AppendResult(interp, "unexpected maximal size", NULL);
+	Tcl_DeleteHashTable(&hash);
+	return TCL_ERROR;
+    }
+
+    for (i=0 ; i<limit ; i++) {
+	hPtr = Tcl_FindHashEntry(&hash, (char *)i);
+	if (hPtr == NULL) {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," lookup problem",-1);
+	    Tcl_DeleteHashTable(&hash);
+	    return TCL_ERROR;
+	}
+	if ((int)(Tcl_GetHashValue(hPtr)) != i+42) {
+	    Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
+	    Tcl_AppendToObj(Tcl_GetObjResult(interp)," value problem",-1);
+	    Tcl_DeleteHashTable(&hash);
+	    return TCL_ERROR;
+	}
+	Tcl_DeleteHashEntry(hPtr);
+    }
+
+    if (hash.numEntries != 0) {
+	Tcl_AppendResult(interp, "non-zero final size", NULL);
+	Tcl_DeleteHashTable(&hash);
+	return TCL_ERROR;
+    }
+
+    Tcl_DeleteHashTable(&hash);
+    Tcl_AppendResult(interp, "OK", NULL);
+    return TCL_OK;
+}
diff --git a/tests/misc.test b/tests/misc.test
index d6536b7..69b08e1 100644
--- a/tests/misc.test
+++ b/tests/misc.test
@@ -12,7 +12,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: misc.test,v 1.6 2003/02/16 01:36:32 msofer Exp $
+# RCS: @(#) $Id: misc.test,v 1.7 2003/11/14 23:21:02 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -66,18 +66,10 @@ missing close-brace for variable name
     invoked from within
 "tstProc"}]
 
+for {set i 1} {$i<300} {incr i} {
+    test misc-2.$i {hash table with sys-alloc} "testhashsystemhash $i" OK
+}
+
 # cleanup
 ::tcltest::cleanupTests
 return
-
-
-
-
-
-
-
-
-
-
-
-
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index eee9d71..bfeb161 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -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: tclUnixPort.h,v 1.30 2003/11/11 08:24:55 davygrvy Exp $
+ * RCS: @(#) $Id: tclUnixPort.h,v 1.31 2003/11/14 23:21:02 dkf Exp $
  */
 
 #ifndef _TCLUNIXPORT
@@ -532,15 +532,12 @@ typedef int socklen_t;
 #define TclpReleaseFile(file)	/* Nothing. */
 
 /*
- * The following defines wrap the system memory allocation routines for
- * use by tclAlloc.c.  By default off unused on Unix.
+ * The following defines wrap the system memory allocation routines.
  */
 
-#if USE_TCLALLOC
-#   define TclpSysAlloc(size, isBin)	malloc((size_t)size)
-#   define TclpSysFree(ptr)		free((char*)ptr)
-#   define TclpSysRealloc(ptr, size)	realloc((char*)ptr, (size_t)size)
-#endif
+#define TclpSysAlloc(size, isBin)	malloc((size_t)size)
+#define TclpSysFree(ptr)		free((char*)ptr)
+#define TclpSysRealloc(ptr, size)	realloc((char*)ptr, (size_t)size)
 
 /*
  * The following macros and declaration wrap the C runtime library