From 8200862cb7c911e184f4b9f35578e67f2000cf11 Mon Sep 17 00:00:00 2001 From: dkf Date: Fri, 14 Nov 2003 23:21:01 +0000 Subject: TIP#138 implementation plus extra test stuff [Patch 731356] --- ChangeLog | 6 ++++ doc/Hash.3 | 13 ++++++++- generic/tcl.h | 7 ++++- generic/tclHash.c | 71 +++++++++++++++++++++++++++++++++++----------- generic/tclTest.c | 83 +++++++++++++++++++++++++++++++++++++++++++++++++++++- tests/misc.test | 18 ++++-------- unix/tclUnixPort.h | 13 ++++----- 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 + * 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 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