From d57677488f057b142552a7611ebd5dd23e0cf359 Mon Sep 17 00:00:00 2001
From: sebres <sebres@users.sourceforge.net>
Date: Fri, 12 Apr 2024 21:13:23 +0000
Subject: amend to [295b0570ff660950]: the bug was fixed incompletely, this is
 full bug fix now - don't allow direct compare if keys contain values rather
 than pointers. introduced new hash-key type flag
 TCL_HASH_KEY_DIRECT_COMPARE... I know it is public interface, but the bug is
 grave, and I don't know how one could fix it without that, by retaining same
 performance for pointer hashes (e. g. vars, dicts and all of TclObjs).

---
 generic/tcl.h        |  8 ++++++++
 generic/tclDictObj.c |  2 +-
 generic/tclHash.c    | 49 ++++++++++++++++++++++++++++++++++---------------
 generic/tclObj.c     |  2 +-
 generic/tclVar.c     |  2 +-
 5 files changed, 45 insertions(+), 18 deletions(-)

diff --git a/generic/tcl.h b/generic/tcl.h
index d71a333..ff7d0d7 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -1162,10 +1162,18 @@ struct Tcl_HashEntry {
  * 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.
+ * TCL_HASH_KEY_DIRECT_COMPARE -
+ * 	                        Allows fast comparison for hash keys directly
+ *                              by compare of their key.oneWordValue values,
+ *                              before call of compareKeysProc (much slower
+ *                              than a direct compare, so it is speed-up only
+ *                              flag). Don't use it if keys contain values rather
+ *                              than pointers.
  */
 
 #define TCL_HASH_KEY_RANDOMIZE_HASH 0x1
 #define TCL_HASH_KEY_SYSTEM_HASH    0x2
+#define TCL_HASH_KEY_DIRECT_COMPARE 0x4
 
 /*
  * Structure definition for the methods associated with a hash table key type.
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index bde8162..3a02bbd 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -168,7 +168,7 @@ Tcl_ObjType tclDictType = {
 
 static Tcl_HashKeyType chainHashType = {
     TCL_HASH_KEY_TYPE_VERSION,
-    0,
+    TCL_HASH_KEY_DIRECT_COMPARE,        /* allows compare keys by pointers */
     TclHashObjKey,
     TclCompareObjKeys,
     AllocChainEntry,
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 02a16a0..40a855b 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -317,23 +317,42 @@ CreateHashEntry(
 
     if (typePtr->compareKeysProc) {
 	Tcl_CompareHashKeysProc *compareKeysProc = typePtr->compareKeysProc;
-	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
-		hPtr = hPtr->nextPtr) {
+
+	if (typePtr->flags & TCL_HASH_KEY_DIRECT_COMPARE) {
+            for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+                    hPtr = hPtr->nextPtr) {
 #if TCL_HASH_KEY_STORE_HASH
-	    if (hash != PTR2UINT(hPtr->hash)) {
-		continue;
-	    }
+                if (hash != PTR2UINT(hPtr->hash)) {
+                    continue;
+                }
 #endif
-	    /* if keys pointers or values are equal */
-	    if ((key == hPtr->key.oneWordValue)
-		|| compareKeysProc((VOID *) key, hPtr)
-	    ) {
-		if (newPtr) {
-		    *newPtr = 0;
-		}
-		return hPtr;
-	    }
-	}
+                /* if keys pointers or values are equal */
+                if ((key == hPtr->key.oneWordValue)
+                    || compareKeysProc((VOID *) key, hPtr)
+                ) {
+                    if (newPtr) {
+                        *newPtr = 0;
+                    }
+                    return hPtr;
+                }
+            }
+        } else {
+            for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
+                    hPtr = hPtr->nextPtr) {
+#if TCL_HASH_KEY_STORE_HASH
+                if (hash != PTR2UINT(hPtr->hash)) {
+                    continue;
+                }
+#endif
+                /* if keys pointers or values are equal */
+                if (compareKeysProc((VOID *) key, hPtr)) {
+                    if (newPtr) {
+                        *newPtr = 0;
+                    }
+                    return hPtr;
+                }
+            }
+        }
     } else {
 	for (hPtr = tablePtr->buckets[index]; hPtr != NULL;
 		hPtr = hPtr->nextPtr) {
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 6bff71c..f5bd137 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -297,7 +297,7 @@ Tcl_ObjType tclBignumType = {
 
 Tcl_HashKeyType tclObjHashKeyType = {
     TCL_HASH_KEY_TYPE_VERSION,	/* version */
-    0,				/* flags */
+    TCL_HASH_KEY_DIRECT_COMPARE,/* allows compare keys by pointers */
     TclHashObjKey,		/* hashKeyProc */
     TclCompareObjKeys,		/* compareKeysProc */
     AllocObjEntry,		/* allocEntryProc */
diff --git a/generic/tclVar.c b/generic/tclVar.c
index d4e5339..baac5da 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -30,7 +30,7 @@ static unsigned int	HashVarKey(Tcl_HashTable *tablePtr, void *keyPtr);
 
 static Tcl_HashKeyType tclVarHashKeyType = {
     TCL_HASH_KEY_TYPE_VERSION,	/* version */
-    0,				/* flags */
+    TCL_HASH_KEY_DIRECT_COMPARE,/* allows compare keys by pointers */
     HashVarKey,			/* hashKeyProc */
     CompareVarKeys,		/* compareKeysProc */
     AllocVarEntry,		/* allocEntryProc */
-- 
cgit v0.12