From 688c125ec305e23f82299d3b321a9c262e8af35f Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Wed, 3 May 2023 13:18:05 +0000
Subject: Fix bug-c9663296fd (in progress)

---
 generic/tclStringObj.c | 56 ++++++++++++++++++++++++++++++--------------------
 generic/tclStringRep.h |  7 ++++---
 2 files changed, 38 insertions(+), 25 deletions(-)

diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index d2bc1b2..33e61a6 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -131,8 +131,8 @@ const Tcl_ObjType tclStringType = {
 static void
 GrowStringBuffer(
     Tcl_Obj *objPtr,
-    size_t needed,
-    int flag)
+    size_t needed, /* Not including terminating nul */
+    int flag)      /* If 0, try to overallocate */
 {
     /*
      * Preconditions:
@@ -145,11 +145,18 @@ GrowStringBuffer(
     char *ptr = NULL;
     size_t attempt;
 
+    assert(needed <= TCL_SIZE_MAX - 1);
+
     if (objPtr->bytes == &tclEmptyString) {
 	objPtr->bytes = NULL;
     }
     if (flag == 0 || stringPtr->allocated > 0) {
-	attempt = 2 * needed;
+	if (needed <= (TCL_SIZE_MAX - needed - 1)) {
+	    /* Doubling space will not overflow */
+	    attempt = 2 * needed;
+	} else {
+	    attempt = TCL_SIZE_MAX - 1;
+	}
 	ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt + 1U);
 	if (ptr == NULL) {
 	    /*
@@ -157,11 +164,11 @@ GrowStringBuffer(
 	     * overflow into invalid argument values for attempt.
 	     */
 
-	    size_t limit = INT_MAX - needed;
-	    size_t extra = needed - objPtr->length + TCL_MIN_GROWTH;
-	    size_t growth = (extra > limit) ? limit : extra;
-
-	    attempt = needed + growth;
+	    if (needed < (TCL_SIZE_MAX - TCL_MIN_GROWTH - 1)) {
+		attempt = needed + TCL_MIN_GROWTH;
+	    } else {
+		attempt = TCL_SIZE_MAX - 1;
+	    }
 	    ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt + 1U);
 	}
     }
@@ -190,32 +197,37 @@ GrowUnicodeBuffer(
 
     String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
     size_t attempt;
+    size_t bytesNeeded; /* Actual storage including header */
 
+    /* Note STRING_MAXCHARS already takes into account space for nul */
+    if (needed > STRING_MAXCHARS) {
+	Tcl_Panic("max size for a Tcl unicode rep (%" TCL_Z_MODIFIER "d bytes) exceeded",
+		  STRING_MAXCHARS);
+    }
     if (stringPtr->maxChars > 0) {
-	/*
-	 * Subsequent appends - apply the growth algorithm.
-	 */
-
-	attempt = 2 * needed;
+	/* Subsequent appends - apply the growth algorithm. */
+	if (needed <= (STRING_MAXCHARS - needed)) {
+	    /* Doubling space will not overflow */
+	    attempt = 2 * needed;
+	} else {
+	    attempt = STRING_MAXCHARS;
+	}
 	ptr = stringAttemptRealloc(stringPtr, attempt);
 	if (ptr == NULL) {
 	    /*
 	     * Take care computing the amount of modest growth to avoid
 	     * overflow into invalid argument values for attempt.
 	     */
-
-	    size_t extra = needed - stringPtr->numChars
-		    + TCL_MIN_UNICHAR_GROWTH;
-
-	    attempt = needed + extra;
+	    if (needed < (STRING_MAXCHARS - TCL_MIN_GROWTH)) {
+		attempt = needed + TCL_MIN_GROWTH;
+	    } else {
+		attempt = STRING_MAXCHARS;
+	    }
 	    ptr = stringAttemptRealloc(stringPtr, attempt);
 	}
     }
     if (ptr == NULL) {
-	/*
-	 * First allocation - just big enough; or last chance fallback.
-	 */
-
+	/* First allocation - just big enough; or last chance fallback. */
 	attempt = needed;
 	ptr = stringRealloc(stringPtr, attempt);
     }
diff --git a/generic/tclStringRep.h b/generic/tclStringRep.h
index 7f72b04..d4b6b2d 100644
--- a/generic/tclStringRep.h
+++ b/generic/tclStringRep.h
@@ -34,9 +34,10 @@ typedef struct {
 				 * calculated. Any other means that there is a valid
 				 * Unicode rep, or that the number of UTF bytes ==
 				 * the number of chars. */
-    Tcl_Size allocated;		/* The amount of space actually allocated for
-				 * the UTF-8 string (minus 1 byte for the
-				 * termination char). */
+    Tcl_Size allocated;		/* The amount of space allocated for
+				 * the UTF-8 string. Does not include nul
+				 * terminator so actual allocation is
+				 * (allocated+1). */
     Tcl_Size maxChars;		/* Max number of chars that can fit in the
 				 * space allocated for the Unicode array. */
     int hasUnicode;		/* Boolean determining whether the string has
-- 
cgit v0.12


From 92dd14e77c81c060ff6ede641885b928afdb9ec3 Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Thu, 4 May 2023 17:52:06 +0000
Subject: Refactor reallocation in preparation for experimentation with
 different growth factors

---
 generic/tclBinary.c    | 36 ++++++---------------
 generic/tclInt.h       | 43 +++++++++++++++++++++++++
 generic/tclListObj.c   | 84 +++++++++++++++++++------------------------------
 generic/tclStringObj.c | 85 +++++++++++++++++++-------------------------------
 tests/stringObj.test   | 12 +++----
 5 files changed, 123 insertions(+), 137 deletions(-)

diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index dd8b292..4215913 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -768,37 +768,21 @@ TclAppendBytesToByteArray(
     needed = byteArrayPtr->used + len;
     if (needed > byteArrayPtr->allocated) {
 	ByteArray *ptr = NULL;
-
-        /*
-	 * Try to allocate double the total space that is needed.
-	 */
-
 	Tcl_Size attempt;
 
-	/* Make sure we do not wrap when doubling */
-	if (needed <= (BYTEARRAY_MAX_LEN - needed)) {
-	    attempt = 2 * needed;
-	    ptr = (ByteArray *) Tcl_AttemptRealloc(byteArrayPtr,
-		    BYTEARRAY_SIZE(attempt));
+        /* First try to overallocate, reducing overallocation on each fail */
+	attempt =
+	    TclUpsizeAlloc(byteArrayPtr->allocated, needed, BYTEARRAY_MAX_LEN);
+	while (attempt > needed) {
+	    ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr,
+						  BYTEARRAY_SIZE(attempt));
+	    if (ptr)
+		break;
+	    attempt = TclUpsizeRetry(needed, attempt);
 	}
 
 	if (ptr == NULL) {
-	    /*
-	     * Try to allocate double the increment that is needed.
-	     * (Originally TCL_MIN_GROWTH was added as well but that would
-	     * need one more separate overflow check so forget it.)
-	     */
-	    if (len <= (BYTEARRAY_MAX_LEN - needed)) {
-		attempt = needed + len;
-		ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr,
-						      BYTEARRAY_SIZE(attempt));
-	    }
-	}
-	if (ptr == NULL) {
-	    /*
-	     * Last chance: Try to allocate exactly what is needed.
-	     */
-
+	    /* Last chance: Try to allocate exactly what is needed. */
 	    attempt = needed;
 	    ptr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
 	}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8f87523..4d2f85d 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2872,6 +2872,49 @@ typedef struct ProcessGlobalValue {
     } while (0)
 
 /*
+ *----------------------------------------------------------------------
+ * Common functions for growing allocations. Trivial but allows for
+ * experimenting with growth factors without having to change code in
+ * multiple places. Usage example:
+ *
+ * allocated = TclUpsizeAlloc(oldSize, needed, TCL_SIZE_MAX);
+ * while (allocated > needed) {
+ *     ptr = Tcl_AttemptRealloc(oldPtr, allocated);
+ *     if (ptr)
+ *         break;
+ *     allocated = TclUpsizeRetry(needed, allocated);
+ * }
+ * if (ptr == NULL) {
+ *     // Last resort - exact size
+ *     allocated = needed; 
+ *     ptr = Tcl_Realloc(oldPtr, allocated);
+ * }
+ * ptr now points to an allocation of size 'allocated'
+ *----------------------------------------------------------------------
+ */
+static inline Tcl_Size
+TclUpsizeAlloc(TCL_UNUSED(Tcl_Size) /*oldSize*/,
+	       Tcl_Size needed,
+	       Tcl_Size limit)
+{
+    /* assert (oldCapacity < needed <= limit) */
+    if (needed < (limit - needed)) {
+	return 2 * needed;
+    } else {
+	return limit;
+    }
+}
+static inline Tcl_Size TclUpsizeRetry(Tcl_Size needed, Tcl_Size lastAttempt) {
+	/* assert (needed < lastAttempt) */
+    if (needed < lastAttempt - 1) {
+	/* (needed+lastAttempt)/2 but that formula may overflow Tcl_Size */
+	return needed + (lastAttempt - needed) / 2;
+    } else {
+	return needed;
+    }
+}
+
+/*
  *----------------------------------------------------------------
  * Variables shared among Tcl modules but not used by the outside world.
  *----------------------------------------------------------------
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 726b8dd..31fb986 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -328,30 +328,6 @@ ListSpanMerited(
 /*
  *------------------------------------------------------------------------
  *
- * ListStoreUpSize --
- *
- *    For reasons of efficiency, extra space is allocated for a ListStore
- *    compared to what was requested. This function calculates how many
- *    slots should actually be allocated for a given request size.
- *
- * Results:
- *    Number of slots to allocate.
- *
- * Side effects:
- *    None.
- *
- *------------------------------------------------------------------------
- */
-static inline Tcl_Size
-ListStoreUpSize(Tcl_Size numSlotsRequested) {
-    /* TODO -how much extra? May be double only for smaller requests? */
-    return numSlotsRequested < (LIST_MAX / 2) ? 2 * numSlotsRequested
-						 : LIST_MAX;
-}
-
-/*
- *------------------------------------------------------------------------
- *
  * ListRepFreeUnreferenced --
  *
  *    Inline wrapper for ListRepUnsharedFreeUnreferenced that does quick checks
@@ -769,25 +745,32 @@ ListStoreNew(
 	return NULL;
     }
 
+    storePtr = NULL;
     if (flags & LISTREP_SPACE_FLAGS) {
 	/* Caller requests extra space front, back or both */
-	capacity = ListStoreUpSize(objc);
+	capacity = TclUpsizeAlloc(0, objc, LIST_MAX);
+	while (capacity > objc) {
+	    storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
+	    if (storePtr)
+		break;
+	    capacity = TclUpsizeRetry(0, capacity);
+	}
     } else {
+	/* Exact allocation */
 	capacity = objc;
     }
-
-    storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
-    while (storePtr == NULL && (capacity > (objc+1))) {
-	/* Because of loop condition capacity won't overflow */
-	capacity = objc + ((capacity - objc) / 2);
-	storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
-    }
     if (storePtr == NULL) {
-	if (flags & LISTREP_PANIC_ON_FAIL) {
-	    Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER "u bytes",
+	/* Either overallocation failed or exact allocation */
+	storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
+	if (storePtr == NULL) {
+	    if (flags & LISTREP_PANIC_ON_FAIL) {
+		Tcl_Panic(
+		    "list creation failed: unable to alloc %" TCL_Z_MODIFIER
+		    "u bytes",
 		    LIST_SIZE(objc));
+	    }
+	    return NULL;
 	}
-	return NULL;
     }
 
     storePtr->refCount = 0;
@@ -844,35 +827,32 @@ ListStoreNew(
  *------------------------------------------------------------------------
  */
 ListStore *
-ListStoreReallocate (ListStore *storePtr, Tcl_Size numSlots)
+ListStoreReallocate (ListStore *storePtr, Tcl_Size needed)
 {
-    Tcl_Size newCapacity;
+    Tcl_Size attempt;
     ListStore *newStorePtr;
 
-    newCapacity = ListStoreUpSize(numSlots);
-    newStorePtr =
-	(ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(newCapacity));
-
-    /*
-     * In case above failed keep looping reducing the requested extra space
-     * by half every time.
-     */
-    while (newStorePtr == NULL && (newCapacity > (numSlots+1))) {
-	/* Because of loop condition newCapacity won't overflow */
-	newCapacity = numSlots + ((newCapacity - numSlots) / 2);
+    /* First try to overallocate, reducing overallocation on each fail */
+    newStorePtr = NULL;
+    attempt = TclUpsizeAlloc(storePtr->numAllocated, needed, LIST_MAX);
+    while (attempt > needed) {
 	newStorePtr =
-	    (ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(newCapacity));
+	    (ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(attempt));
+	if (newStorePtr)
+	    break;
+	attempt = TclUpsizeRetry(needed, attempt);
     }
+
     if (newStorePtr == NULL) {
 	/* Last resort - allcate what was asked */
-	newCapacity = numSlots;
+	attempt = needed;
 	newStorePtr = (ListStore *)Tcl_AttemptRealloc(storePtr,
-						    LIST_SIZE(newCapacity));
+						    LIST_SIZE(attempt));
 	if (newStorePtr == NULL)
 	    return NULL;
     }
     /* Only the capacity has changed, fix it in the header */
-    newStorePtr->numAllocated = newCapacity;
+    newStorePtr->numAllocated = attempt;
     return newStorePtr;
 }
 
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 33e61a6..7cf0e09 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -59,8 +59,8 @@ static void		ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
 			    Tcl_Size numAppendChars);
 static void		FillUnicodeRep(Tcl_Obj *objPtr);
 static void		FreeStringInternalRep(Tcl_Obj *objPtr);
-static void		GrowStringBuffer(Tcl_Obj *objPtr, size_t needed, int flag);
-static void		GrowUnicodeBuffer(Tcl_Obj *objPtr, size_t needed);
+static void		GrowStringBuffer(Tcl_Obj *objPtr, Tcl_Size needed, int flag);
+static void		GrowUnicodeBuffer(Tcl_Obj *objPtr, Tcl_Size needed);
 static int		SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
 static void		SetUnicodeObj(Tcl_Obj *objPtr,
 			    const Tcl_UniChar *unicode, Tcl_Size numChars);
@@ -131,7 +131,7 @@ const Tcl_ObjType tclStringType = {
 static void
 GrowStringBuffer(
     Tcl_Obj *objPtr,
-    size_t needed, /* Not including terminating nul */
+    Tcl_Size needed, /* Not including terminating nul */
     int flag)      /* If 0, try to overallocate */
 {
     /*
@@ -142,52 +142,43 @@ GrowStringBuffer(
      */
 
     String *stringPtr = GET_STRING(objPtr);
-    char *ptr = NULL;
-    size_t attempt;
+    char *ptr;
+    Tcl_Size attempt;
 
     assert(needed <= TCL_SIZE_MAX - 1);
+    needed += 1; /* Include terminating nul */
 
     if (objPtr->bytes == &tclEmptyString) {
 	objPtr->bytes = NULL;
     }
+    /* 
+     * In code below, note 'attempt' and 'needed' include terminating nul,
+     * while stringPtr->allocated does not.
+     */
+    ptr = NULL;
     if (flag == 0 || stringPtr->allocated > 0) {
-	if (needed <= (TCL_SIZE_MAX - needed - 1)) {
-	    /* Doubling space will not overflow */
-	    attempt = 2 * needed;
-	} else {
-	    attempt = TCL_SIZE_MAX - 1;
-	}
-	ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt + 1U);
-	if (ptr == NULL) {
-	    /*
-	     * Take care computing the amount of modest growth to avoid
-	     * overflow into invalid argument values for attempt.
-	     */
-
-	    if (needed < (TCL_SIZE_MAX - TCL_MIN_GROWTH - 1)) {
-		attempt = needed + TCL_MIN_GROWTH;
-	    } else {
-		attempt = TCL_SIZE_MAX - 1;
-	    }
-	    ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt + 1U);
+	attempt =
+	    TclUpsizeAlloc(stringPtr->allocated + 1, needed, TCL_SIZE_MAX);
+	while (attempt > needed) {
+	    ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt);
+	    if (ptr)
+		break;
+	    attempt = TclUpsizeRetry(needed, attempt);
 	}
     }
     if (ptr == NULL) {
-	/*
-	 * First allocation - just big enough; or last chance fallback.
-	 */
-
+	/* First allocation - just big enough; or last chance fallback. */
 	attempt = needed;
-	ptr = (char *)Tcl_Realloc(objPtr->bytes, attempt + 1U);
+	ptr = (char *)Tcl_Realloc(objPtr->bytes, attempt);
     }
     objPtr->bytes = ptr;
-    stringPtr->allocated = attempt;
+    stringPtr->allocated = attempt - 1; /* Does not include slot for end nul */
 }
 
 static void
 GrowUnicodeBuffer(
     Tcl_Obj *objPtr,
-    size_t needed)
+    Tcl_Size needed)
 {
     /*
      * Preconditions:
@@ -195,41 +186,29 @@ GrowUnicodeBuffer(
      *	needed > stringPtr->maxChars
      */
 
-    String *ptr = NULL, *stringPtr = GET_STRING(objPtr);
-    size_t attempt;
-    size_t bytesNeeded; /* Actual storage including header */
+    String *ptr, *stringPtr = GET_STRING(objPtr);
+    Tcl_Size attempt;
 
     /* Note STRING_MAXCHARS already takes into account space for nul */
     if (needed > STRING_MAXCHARS) {
 	Tcl_Panic("max size for a Tcl unicode rep (%" TCL_Z_MODIFIER "d bytes) exceeded",
 		  STRING_MAXCHARS);
     }
+    ptr = NULL;
     if (stringPtr->maxChars > 0) {
 	/* Subsequent appends - apply the growth algorithm. */
-	if (needed <= (STRING_MAXCHARS - needed)) {
-	    /* Doubling space will not overflow */
-	    attempt = 2 * needed;
-	} else {
-	    attempt = STRING_MAXCHARS;
-	}
-	ptr = stringAttemptRealloc(stringPtr, attempt);
-	if (ptr == NULL) {
-	    /*
-	     * Take care computing the amount of modest growth to avoid
-	     * overflow into invalid argument values for attempt.
-	     */
-	    if (needed < (STRING_MAXCHARS - TCL_MIN_GROWTH)) {
-		attempt = needed + TCL_MIN_GROWTH;
-	    } else {
-		attempt = STRING_MAXCHARS;
-	    }
-	    ptr = stringAttemptRealloc(stringPtr, attempt);
+	attempt = TclUpsizeAlloc(stringPtr->maxChars, needed, STRING_MAXCHARS);
+	while (attempt > needed) {
+	    ptr = (String *)Tcl_AttemptRealloc(stringPtr, STRING_SIZE(attempt));
+	    if (ptr)
+		break;
+	    attempt = TclUpsizeRetry(needed, attempt);
 	}
     }
     if (ptr == NULL) {
 	/* First allocation - just big enough; or last chance fallback. */
 	attempt = needed;
-	ptr = stringRealloc(stringPtr, attempt);
+	ptr = (String *)Tcl_Realloc(stringPtr, STRING_SIZE(attempt));
     }
     stringPtr = ptr;
     stringPtr->maxChars = attempt;
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 5b6358a..7191ed6 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -78,7 +78,7 @@ test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} testobj {
     teststringobj append 1 xyzq -1
     list [teststringobj length 1] [teststringobj length2 1] \
 	    [teststringobj get 1]
-} {10 20 abcdefxyzq}
+} {10 21 abcdefxyzq}
 test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} testobj {
     testobj freeallvars
     testobj newobj 1
@@ -111,7 +111,7 @@ test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj {
     teststringobj append 1 abcdef -1
     lappend result [teststringobj length 1] [teststringobj length2 1] \
 	    [teststringobj get 1]
-} {15 15 16 32 xy12345678abcdef}
+} {15 15 16 33 xy12345678abcdef}
 
 test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} testobj {
     testobj freeallvars
@@ -142,7 +142,7 @@ test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if init
     testobj newobj 1
     teststringobj appendstrings 1 123 abcdefg
     list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1]
-} {10 20 123abcdefg}
+} {10 21 123abcdefg}
 test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj {
     testobj freeallvars
     teststringobj set 1 abc
@@ -160,7 +160,7 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testob
     teststringobj appendstrings 1 34567890x
     list [teststringobj length 1] [teststringobj length2 1] \
 	    [teststringobj get 1]
-} {11 22 ab34567890x}
+} {11 23 ab34567890x}
 test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj {
     testobj freeallvars
     testobj newobj 1
@@ -180,7 +180,7 @@ test stringObj-7.1 {SetStringFromAny procedure} testobj {
     teststringobj append 1 x -1
     list [teststringobj length 1] [teststringobj length2 1] \
 	    [teststringobj get 1]
-} {4 8 {a bx}}
+} {4 9 {a bx}}
 test stringObj-7.2 {SetStringFromAny procedure, null object} testobj {
     testobj freeallvars
     testobj newobj 1
@@ -208,7 +208,7 @@ test stringObj-8.1 {DupStringInternalRep procedure} testobj {
 	    [teststringobj maxchars 1] [teststringobj get 1] \
 	    [teststringobj length 2] [teststringobj length2 2] \
 	    [teststringobj maxchars 2] [teststringobj get 2]
-} {5 10 0 abcde 5 5 0 abcde}
+} {5 11 0 abcde 5 5 0 abcde}
 test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj {
     set x abc\xEF\xBF\xAEghi
     string length $x
-- 
cgit v0.12


From 5940356ced08a62f3dedc17888f34345dd09af61 Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Fri, 5 May 2023 09:17:17 +0000
Subject: Change reallocation growth to 1.5.

---
 generic/tclInt.h     |  7 ++++---
 tests/listRep.test   | 32 ++++++++++++++++----------------
 tests/stringObj.test | 12 ++++++------
 3 files changed, 26 insertions(+), 25 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 4d2f85d..660c19f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2898,9 +2898,10 @@ TclUpsizeAlloc(TCL_UNUSED(Tcl_Size) /*oldSize*/,
 	       Tcl_Size limit)
 {
     /* assert (oldCapacity < needed <= limit) */
-    if (needed < (limit - needed)) {
-	return 2 * needed;
-    } else {
+    if (needed < (limit - needed/2)) {
+	return needed + needed / 2;
+    }
+    else {
 	return limit;
     }
 }
diff --git a/tests/listRep.test b/tests/listRep.test
index 02ff18f..11af9ad 100644
--- a/tests/listRep.test
+++ b/tests/listRep.test
@@ -221,7 +221,7 @@ test listrep-1.2 {
     set l [linsert [freeSpaceNone] $end 99]
     validate $l
     list $l [leadSpace $l] [tailSpace $l]
-} -result [list {0 1 2 3 4 5 6 7 99} 0 9]
+} -result [list {0 1 2 3 4 5 6 7 99} 0 4]
 
 test listrep-1.2.1 {
     Inserts at back of unshared list with no free space should allocate all
@@ -231,7 +231,7 @@ test listrep-1.2.1 {
     lset l $end+1 99
     validate $l
     list $l [leadSpace $l] [tailSpace $l]
-} -result [list {0 1 2 3 4 5 6 7 99} 0 9]
+} -result [list {0 1 2 3 4 5 6 7 99} 0 4]
 
 test listrep-1.2.2 {
     Inserts at back of unshared list with no free space should allocate all
@@ -241,7 +241,7 @@ test listrep-1.2.2 {
     lappend l 99
     validate $l
     list $l [leadSpace $l] [tailSpace $l]
-} -result [list {0 1 2 3 4 5 6 7 99} 0 9]
+} -result [list {0 1 2 3 4 5 6 7 99} 0 4]
 
 test listrep-1.3 {
     Inserts in middle of unshared list with no free space should reallocate with
@@ -1160,7 +1160,7 @@ test listrep-3.3 {
     set l [linsert [freeSpaceBoth 8 1 1] $zero -3 -2 -1]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list [irange -3 7] 6 5 1]
+} -result [list [irange -3 7] 3 2 1]
 
 test listrep-3.3.1 {
     Inserts in front of unshared spanned list with insufficient total freespace
@@ -1169,7 +1169,7 @@ test listrep-3.3.1 {
     set l [lreplace [freeSpaceBoth 8 1 1] $zero -1 -3 -2 -1]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list [irange -3 7] 6 5 1]
+} -result [list [irange -3 7] 3 2 1]
 
 test listrep-3.4 {
     Inserts at back of unshared spanned list with room at back should not
@@ -1255,7 +1255,7 @@ test listrep-3.6 {
     set l [linsert [freeSpaceBoth 8 1 1] $end 8 9 10]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list [irange 0 10] 1 10 1]
+} -result [list [irange 0 10] 1 4 1]
 
 test listrep-3.6.1 {
     Inserts in back of unshared spanned list with insufficient total freespace
@@ -1265,7 +1265,7 @@ test listrep-3.6.1 {
     set l [lreplace [freeSpaceBoth 8 1 1] $end+1 $end+1 8 9 10]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list [irange 0 10] 1 10 1]
+} -result [list [irange 0 10] 1 4 1]
 
 test listrep-3.6.2 {
     Inserts in back of unshared spanned list with insufficient total freespace
@@ -1276,7 +1276,7 @@ test listrep-3.6.2 {
     lappend l 8 9 10
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list [irange 0 10] 1 10 1]
+} -result [list [irange 0 10] 1 4 1]
 
 test listrep-3.6.3 {
     Inserts in back of unshared spanned list with insufficient total freespace
@@ -1287,7 +1287,7 @@ test listrep-3.6.3 {
     lset l $end+1 8
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list [irange 0 8] 0 9 1]
+} -result [list [irange 0 8] 0 4 1]
 
 test listrep-3.7 {
     Inserts in front half of unshared spanned list with room in front should not
@@ -1341,7 +1341,7 @@ test listrep-3.10 {
     set l [linsert [freeSpaceBoth 8 1 1] $one -3 -2 -1]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1]
+} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 4 1]
 
 test listrep-3.10.1 {
     Inserts in front half of unshared spanned list with insufficient total space.
@@ -1350,7 +1350,7 @@ test listrep-3.10.1 {
     set l [lreplace [freeSpaceBoth 8 1 1] $one -1 -3 -2 -1]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 10 1]
+} -result [list {0 -3 -2 -1 1 2 3 4 5 6 7} 1 4 1]
 
 test listrep-3.11 {
     Inserts in back half of unshared spanned list with room in back should not
@@ -1414,7 +1414,7 @@ test listrep-3.14 {
     set l [linsert [freeSpaceBoth 8 1 1] $end-$one 8 9 10]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1]
+} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 4 1]
 
 test listrep-3.14.1 {
     Inserts in back half of unshared spanned list with insufficient
@@ -1424,7 +1424,7 @@ test listrep-3.14.1 {
     set l [lreplace [freeSpaceBoth 8 1 1] $end -1 8 9 10]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 10 1]
+} -result [list {0 1 2 3 4 5 6 8 9 10 7} 1 4 1]
 
 test listrep-3.15 {
     Deletes from front of small unshared span list results in elements
@@ -1714,7 +1714,7 @@ test listrep-3.27 {
     set l [lreplace [freeSpaceBoth 8 1 1] $zero $one 10 11 12 13 14]
     validate $l
     list $l [leadSpace $l] [tailSpace $l] [repStoreRefCount $l]
-} -result [list {10 11 12 13 14 2 3 4 5 6 7} 6 5 1]
+} -result [list {10 11 12 13 14 2 3 4 5 6 7} 3 2 1]
 
 test listrep-3.28 {
     Replacement of elements at back with same number of elements in unshared
@@ -1770,7 +1770,7 @@ test listrep-3.32 {
     set l [lreplace [freeSpaceBoth 8 1 1] $end-1 $end 10 11 12 13 14]
     validate $l
     list $l [leadSpace $l] [tailSpace $l]
-} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 10]
+} -result [list {0 1 2 3 4 5 10 11 12 13 14} 1 4]
 
 test listrep-3.33 {
     Replacement of elements in the middle in an unshared spanned list with
@@ -1864,7 +1864,7 @@ test listrep-3.41 {
     set l [lreplace [freeSpaceBoth 8 1 1] $one $one 8 9 10 11 12]
     validate $l
     list $l [leadSpace $l] [tailSpace $l]
-} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 11]
+} -result [list {0 8 9 10 11 12 2 3 4 5 6 7} 1 5]
 
 #
 # 4.* - tests on shared spanned lists
diff --git a/tests/stringObj.test b/tests/stringObj.test
index 7191ed6..71cf63e 100644
--- a/tests/stringObj.test
+++ b/tests/stringObj.test
@@ -78,7 +78,7 @@ test stringObj-4.3 {Tcl_SetObjLength procedure, string gets longer} testobj {
     teststringobj append 1 xyzq -1
     list [teststringobj length 1] [teststringobj length2 1] \
 	    [teststringobj get 1]
-} {10 21 abcdefxyzq}
+} {10 15 abcdefxyzq}
 test stringObj-4.4 {Tcl_SetObjLength procedure, "empty string", length 0} testobj {
     testobj freeallvars
     testobj newobj 1
@@ -111,7 +111,7 @@ test stringObj-5.3 {Tcl_AppendToObj procedure, reallocating space} testobj {
     teststringobj append 1 abcdef -1
     lappend result [teststringobj length 1] [teststringobj length2 1] \
 	    [teststringobj get 1]
-} {15 15 16 33 xy12345678abcdef}
+} {15 15 16 24 xy12345678abcdef}
 
 test stringObj-6.1 {Tcl_AppendStringsToObj procedure, type conversion} testobj {
     testobj freeallvars
@@ -142,7 +142,7 @@ test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if init
     testobj newobj 1
     teststringobj appendstrings 1 123 abcdefg
     list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1]
-} {10 21 123abcdefg}
+} {10 15 123abcdefg}
 test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj {
     testobj freeallvars
     teststringobj set 1 abc
@@ -160,7 +160,7 @@ test stringObj-6.7 {Tcl_AppendStringsToObj procedure, space reallocation} testob
     teststringobj appendstrings 1 34567890x
     list [teststringobj length 1] [teststringobj length2 1] \
 	    [teststringobj get 1]
-} {11 23 ab34567890x}
+} {11 17 ab34567890x}
 test stringObj-6.8 {Tcl_AppendStringsToObj procedure, object totally empty} testobj {
     testobj freeallvars
     testobj newobj 1
@@ -180,7 +180,7 @@ test stringObj-7.1 {SetStringFromAny procedure} testobj {
     teststringobj append 1 x -1
     list [teststringobj length 1] [teststringobj length2 1] \
 	    [teststringobj get 1]
-} {4 9 {a bx}}
+} {4 6 {a bx}}
 test stringObj-7.2 {SetStringFromAny procedure, null object} testobj {
     testobj freeallvars
     testobj newobj 1
@@ -208,7 +208,7 @@ test stringObj-8.1 {DupStringInternalRep procedure} testobj {
 	    [teststringobj maxchars 1] [teststringobj get 1] \
 	    [teststringobj length 2] [teststringobj length2 2] \
 	    [teststringobj maxchars 2] [teststringobj get 2]
-} {5 11 0 abcde 5 5 0 abcde}
+} {5 8 0 abcde 5 5 0 abcde}
 test stringObj-8.2 {DupUnicodeInternalRep, mixed width chars} testobj {
     set x abc\xEF\xBF\xAEghi
     string length $x
-- 
cgit v0.12


From 363a6cc4cdaa5d5e46cfe0efb2d195c2be317435 Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Wed, 10 May 2023 21:32:16 +0000
Subject: Refactor allocation strategy in Tcl_DStringAppend

---
 generic/tcl.h     |  4 ++--
 generic/tclUtil.c | 48 ++++++++++++++++++++++++++++++++++++------------
 2 files changed, 38 insertions(+), 14 deletions(-)

diff --git a/generic/tcl.h b/generic/tcl.h
index ddd9d9b..b43fcec 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -809,8 +809,8 @@ typedef struct {
 typedef struct Tcl_DString {
     char *string;		/* Points to beginning of string: either
 				 * staticSpace below or a malloced array. */
-    Tcl_Size length;		/* Number of non-NULL characters in the
-				 * string. */
+    Tcl_Size length;		/* Number of bytes in string excluding
+				 * terminating nul */
     Tcl_Size spaceAvl;		/* Total number of bytes available for the
 				 * string and its terminating NULL char. */
     char staticSpace[TCL_DSTRING_STATIC_SIZE];
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 6112869..6ce783f 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2602,32 +2602,56 @@ Tcl_DStringAppend(
     if (length < 0) {
 	length = strlen(bytes);
     }
-    newSize = length + dsPtr->length;
 
-    /*
-     * Allocate a larger buffer for the string if the current one isn't large
-     * enough. Allocate extra space in the new buffer so that there will be
-     * room to grow before we have to allocate again.
-     */
+    if (length > (TCL_SIZE_MAX - dsPtr->length - 1)) {
+	Tcl_Panic("max size for a Tcl value (%" TCL_SIZE_MODIFIER
+		  "d bytes) exceeded",
+		  TCL_SIZE_MAX);
+	return NULL; /* NOTREACHED */
+    }
+    newSize = length + dsPtr->length + 1;
 
-    if (newSize >= dsPtr->spaceAvl) {
-	dsPtr->spaceAvl = newSize * 2;
-	if (dsPtr->string == dsPtr->staticSpace) {
-	    char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl);
 
+    if (newSize > dsPtr->spaceAvl) {
+	/* Current allocation not enough */
+	char *newString;
+	dsPtr->spaceAvl =
+	    TclUpsizeAlloc(dsPtr->spaceAvl, newSize, TCL_SIZE_MAX);
+	if (dsPtr->string == dsPtr->staticSpace) {
+	    while (dsPtr->spaceAvl > newSize) {
+		newString = (char *)Tcl_AttemptAlloc(dsPtr->spaceAvl);
+		if (newString)
+		    break;
+		dsPtr->spaceAvl = TclUpsizeRetry(newSize, dsPtr->spaceAvl);
+	    }
+	    if (newString == NULL) {
+		dsPtr->spaceAvl = newSize;
+		newString = Tcl_Alloc(dsPtr->spaceAvl);
+	    }
 	    memcpy(newString, dsPtr->string, dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
-	    Tcl_Size index = TCL_INDEX_NONE;
+	    Tcl_Size index = -1;
 
 	    /* See [16896d49fd] */
 	    if (bytes >= dsPtr->string
 		    && bytes <= dsPtr->string + dsPtr->length) {
+		/* Source string is within this DString. Note offset */
 		index = bytes - dsPtr->string;
 	    }
 
-	    dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
+	    while (dsPtr->spaceAvl > newSize) {
+		newString = (char *)Tcl_AttemptRealloc(dsPtr->string, dsPtr->spaceAvl);
+		if (newString)
+		    break;
+		dsPtr->spaceAvl = TclUpsizeRetry(newSize, dsPtr->spaceAvl);
+	    }
+	    if (newString == NULL) {
+		dsPtr->spaceAvl = newSize;
+		newString = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
+	    }
 
+	    dsPtr->string = newString;
 	    if (index >= 0) {
 		bytes = dsPtr->string + index;
 	    }
-- 
cgit v0.12


From 02563b1911feda87ad86d89bb18855a930ba178e Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Mon, 15 May 2023 20:23:05 +0000
Subject: Refactor allocation in Tcl_DStringAppendElement

---
 generic/tclUtil.c | 47 +++++++++++++++++++++++++++++++++--------------
 1 file changed, 33 insertions(+), 14 deletions(-)

diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 6ce783f..455b2a9 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2613,7 +2613,6 @@ Tcl_DStringAppend(
 
 
     if (newSize > dsPtr->spaceAvl) {
-	/* Current allocation not enough */
 	char *newString;
 	dsPtr->spaceAvl =
 	    TclUpsizeAlloc(dsPtr->spaceAvl, newSize, TCL_SIZE_MAX);
@@ -2626,18 +2625,18 @@ Tcl_DStringAppend(
 	    }
 	    if (newString == NULL) {
 		dsPtr->spaceAvl = newSize;
-		newString = Tcl_Alloc(dsPtr->spaceAvl);
+		newString = (char *) Tcl_Alloc(dsPtr->spaceAvl);
 	    }
 	    memcpy(newString, dsPtr->string, dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
-	    Tcl_Size index = -1;
+	    Tcl_Size offset = -1;
 
 	    /* See [16896d49fd] */
 	    if (bytes >= dsPtr->string
 		    && bytes <= dsPtr->string + dsPtr->length) {
 		/* Source string is within this DString. Note offset */
-		index = bytes - dsPtr->string;
+		offset = bytes - dsPtr->string;
 	    }
 
 	    while (dsPtr->spaceAvl > newSize) {
@@ -2648,12 +2647,12 @@ Tcl_DStringAppend(
 	    }
 	    if (newString == NULL) {
 		dsPtr->spaceAvl = newSize;
-		newString = Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
+		newString = (char *) Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
 	    }
 
 	    dsPtr->string = newString;
-	    if (index >= 0) {
-		bytes = dsPtr->string + index;
+	    if (offset >= 0) {
+		bytes = dsPtr->string + offset;
 	    }
 	}
     }
@@ -2765,12 +2764,22 @@ Tcl_DStringAppendElement(
      * memcpy, not strcpy, to copy the string to a larger buffer, since there
      * may be embedded NULLs in the string in some cases.
      */
-
-    if (newSize >= dsPtr->spaceAvl) {
-	dsPtr->spaceAvl = newSize * 2;
+    newSize += 1; /* For terminating nul */
+    if (newSize > dsPtr->spaceAvl) {
+	char *newString;
+	dsPtr->spaceAvl =
+	    TclUpsizeAlloc(dsPtr->spaceAvl, newSize, TCL_SIZE_MAX);
 	if (dsPtr->string == dsPtr->staticSpace) {
-	    char *newString = (char *)Tcl_Alloc(dsPtr->spaceAvl);
-
+	    while (dsPtr->spaceAvl > newSize) {
+		newString = (char *)Tcl_AttemptAlloc(dsPtr->spaceAvl);
+		if (newString)
+		    break;
+		dsPtr->spaceAvl = TclUpsizeRetry(newSize, dsPtr->spaceAvl);
+	    }
+	    if (newString == NULL) {
+		dsPtr->spaceAvl = newSize;
+		newString = (char *) Tcl_Alloc(dsPtr->spaceAvl);
+	    }
 	    memcpy(newString, dsPtr->string, dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
@@ -2779,11 +2788,21 @@ Tcl_DStringAppendElement(
 	    /* See [16896d49fd] */
 	    if (element >= dsPtr->string
 		    && element <= dsPtr->string + dsPtr->length) {
+		/* Source string is within this DString. Note offset */
 		offset = element - dsPtr->string;
 	    }
+	    while (dsPtr->spaceAvl > newSize) {
+		newString = (char *)Tcl_AttemptRealloc(dsPtr->string, dsPtr->spaceAvl);
+		if (newString)
+		    break;
+		dsPtr->spaceAvl = TclUpsizeRetry(newSize, dsPtr->spaceAvl);
+	    }
+	    if (newString == NULL) {
+		dsPtr->spaceAvl = newSize;
+		newString = (char *) Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
+	    }
 
-	    dsPtr->string = (char *)Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
-
+	    dsPtr->string = newString;
 	    if (offset >= 0) {
 		element = dsPtr->string + offset;
 	    }
-- 
cgit v0.12


From 6fa73194d556765f6a8dfe33c0f609377d5fb41c Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Mon, 15 May 2023 23:08:17 +0000
Subject: Refactor couple more reallocations

---
 generic/tclCkalloc.c | 141 +++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h     |  25 ++++-----
 generic/tclUtil.c    |  72 ++++++--------------------
 3 files changed, 168 insertions(+), 70 deletions(-)

diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 09e140a..1539f4f 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -1194,6 +1194,147 @@ Tcl_DbCkfree(
 }
 
 /*
+ *------------------------------------------------------------------------
+ *
+ * TclAttemptOverAlloc --
+ *
+ *    Attempts to allocates memory of the requested size plus some more for
+ *    future growth.
+ *
+ * Results:
+ *    Pointer to allocated memory block which is at least as large
+ *    as the requested size or NULL if allocation failed.
+ *
+ *------------------------------------------------------------------------
+ */
+void *
+TclAttemptOverAlloc(
+	Tcl_Size needed,	/* Requested size */
+	Tcl_Size *allocatedPtr) /* OUTPUT: Actual allocation size is stored
+				   here if non-NULL. Only modified on success */
+{
+    void *ptr;
+    Tcl_Size attempt = TclUpsizeAlloc(0, needed, TCL_SIZE_MAX);
+    while (attempt > needed) {
+	ptr = Tcl_AttemptAlloc(attempt);
+	if (ptr)
+	    break;
+	attempt = TclUpsizeRetry(needed, attempt);
+    }
+    if (ptr == NULL) {
+	/* Try exact size as a last resort */
+	attempt = needed;
+	ptr = Tcl_AttemptAlloc(attempt);
+    }
+    if (ptr && allocatedPtr) {
+	*allocatedPtr = attempt;
+    }
+    return ptr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclOverAlloc --
+ *
+ *    Allocates memory of the requested size plus some more for future
+ *    growth.
+ *
+ * Results:
+ *    Non-NULL pointer to allocated memory block which is at least as large
+ *    as the requested size.
+ *
+ * Side effects:
+ *    Panics if memory of at least the requested size could not be
+ *    allocated.
+ *
+ *------------------------------------------------------------------------
+ */
+void *
+TclOverAlloc(Tcl_Size needed, Tcl_Size *allocatedPtr)
+{
+    void *ptr = TclAttemptOverAlloc(needed, allocatedPtr);
+    if (ptr == NULL) {
+	Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER "d bytes.", needed);
+    }
+    return ptr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclAttemptOverRealloc --
+ *
+ *    Attempts to reallocate memory of the requested size plus some more for
+ *    future growth.
+ *
+ * Results:
+ *    Pointer to allocated memory block which is at least as large
+ *    as the requested size or NULL if allocation failed.
+ *
+ *------------------------------------------------------------------------
+ */
+void *
+TclAttemptOverRealloc(
+    Tcl_Size needed,        /* Requested size */
+    void *oldPtr,	    /* Pointer to memory block to reallocate */
+    Tcl_Size oldSize,       /* Old size if known, or 0 if unknown */
+    Tcl_Size *allocatedPtr) /* OUTPUT: Actual allocation size is stored
+			       here if non-NULL. Only modified on success */
+{
+    void *ptr;
+    Tcl_Size attempt = TclUpsizeAlloc(oldSize, needed, TCL_SIZE_MAX);
+    while (attempt > needed) {
+	ptr = Tcl_AttemptRealloc(oldPtr, attempt);
+	if (ptr)
+	    break;
+	attempt = TclUpsizeRetry(needed, attempt);
+    }
+    if (ptr == NULL) {
+	/* Try exact size as a last resort */
+	attempt = needed;
+	ptr = Tcl_AttemptRealloc(oldPtr, attempt);
+    }
+    if (ptr && allocatedPtr) {
+	*allocatedPtr = attempt;
+    }
+    return ptr;
+}
+
+/*
+ *------------------------------------------------------------------------
+ *
+ * TclOverRealloc --
+ *
+ *    Reallocates memory of the requested size plus some more for future
+ *    growth.
+ *
+ * Results:
+ *    Non-NULL pointer to allocated memory block which is at least as large
+ *    as the requested size.
+ *
+ * Side effects:
+ *    Panics if memory of at least the requested size could not be
+ *    allocated.
+ *
+ *------------------------------------------------------------------------
+ */
+void *
+TclOverRealloc(
+    Tcl_Size needed,        /* Requested size */
+    void *oldPtr,	    /* Pointer to memory block to reallocate */
+    Tcl_Size oldSize,       /* Old size if known, or 0 if unknown */
+    Tcl_Size *allocatedPtr) /* OUTPUT: Actual allocation size is stored
+			       here if non-NULL. Only modified on success */
+{
+    void *ptr = TclAttemptOverRealloc(needed, oldPtr, oldSize, allocatedPtr);
+    if (ptr == NULL) {
+	Tcl_Panic("Failed to reallocate %" TCL_SIZE_MODIFIER "d bytes.", needed);
+    }
+    return ptr;
+}
+
+/*
  *----------------------------------------------------------------------
  *
  * Tcl_InitMemory --
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 660c19f..56bef02 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2875,21 +2875,12 @@ typedef struct ProcessGlobalValue {
  *----------------------------------------------------------------------
  * Common functions for growing allocations. Trivial but allows for
  * experimenting with growth factors without having to change code in
- * multiple places. Usage example:
+ * multiple places. See TclAttemptOverAlloc and TclAttemptOverRealloc for
+ * usage examples. Best to use those functions if allocating in bytes.
+ * Direct use of TclUpsizeAlloc / TclResizeAlloc is needed if allocating in other 
+ * units (say Tcl_UniChar), if there is a fixed size header involved or if
+ * the max limit is something other than TCL_SIZE_MAX.
  *
- * allocated = TclUpsizeAlloc(oldSize, needed, TCL_SIZE_MAX);
- * while (allocated > needed) {
- *     ptr = Tcl_AttemptRealloc(oldPtr, allocated);
- *     if (ptr)
- *         break;
- *     allocated = TclUpsizeRetry(needed, allocated);
- * }
- * if (ptr == NULL) {
- *     // Last resort - exact size
- *     allocated = needed; 
- *     ptr = Tcl_Realloc(oldPtr, allocated);
- * }
- * ptr now points to an allocation of size 'allocated'
  *----------------------------------------------------------------------
  */
 static inline Tcl_Size
@@ -2914,6 +2905,12 @@ static inline Tcl_Size TclUpsizeRetry(Tcl_Size needed, Tcl_Size lastAttempt) {
 	return needed;
     }
 }
+MODULE_SCOPE void *TclOverAlloc(Tcl_Size needed, Tcl_Size *allocatedPtr);
+MODULE_SCOPE void *TclAttemptOverAlloc(Tcl_Size needed, Tcl_Size *allocatedPtr);
+MODULE_SCOPE void *TclOverRealloc(Tcl_Size needed, void *oldPtr,
+			Tcl_Size oldSize, Tcl_Size *allocatedPtr);
+MODULE_SCOPE void *TclAttemptOverRealloc(Tcl_Size needed, void *oldPtr,
+			Tcl_Size oldSize, Tcl_Size *allocatedPtr);
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 455b2a9..e8cd164 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2613,20 +2613,9 @@ Tcl_DStringAppend(
 
 
     if (newSize > dsPtr->spaceAvl) {
-	char *newString;
-	dsPtr->spaceAvl =
-	    TclUpsizeAlloc(dsPtr->spaceAvl, newSize, TCL_SIZE_MAX);
 	if (dsPtr->string == dsPtr->staticSpace) {
-	    while (dsPtr->spaceAvl > newSize) {
-		newString = (char *)Tcl_AttemptAlloc(dsPtr->spaceAvl);
-		if (newString)
-		    break;
-		dsPtr->spaceAvl = TclUpsizeRetry(newSize, dsPtr->spaceAvl);
-	    }
-	    if (newString == NULL) {
-		dsPtr->spaceAvl = newSize;
-		newString = (char *) Tcl_Alloc(dsPtr->spaceAvl);
-	    }
+	    char *newString;
+	    newString = (char *) TclOverAlloc(newSize, &dsPtr->spaceAvl);
 	    memcpy(newString, dsPtr->string, dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
@@ -2638,19 +2627,8 @@ Tcl_DStringAppend(
 		/* Source string is within this DString. Note offset */
 		offset = bytes - dsPtr->string;
 	    }
-
-	    while (dsPtr->spaceAvl > newSize) {
-		newString = (char *)Tcl_AttemptRealloc(dsPtr->string, dsPtr->spaceAvl);
-		if (newString)
-		    break;
-		dsPtr->spaceAvl = TclUpsizeRetry(newSize, dsPtr->spaceAvl);
-	    }
-	    if (newString == NULL) {
-		dsPtr->spaceAvl = newSize;
-		newString = (char *) Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
-	    }
-
-	    dsPtr->string = newString;
+	    dsPtr->string = (char *) TclOverRealloc(
+		newSize, dsPtr->string, dsPtr->spaceAvl, &dsPtr->spaceAvl);
 	    if (offset >= 0) {
 		bytes = dsPtr->string + offset;
 	    }
@@ -2766,20 +2744,9 @@ Tcl_DStringAppendElement(
      */
     newSize += 1; /* For terminating nul */
     if (newSize > dsPtr->spaceAvl) {
-	char *newString;
-	dsPtr->spaceAvl =
-	    TclUpsizeAlloc(dsPtr->spaceAvl, newSize, TCL_SIZE_MAX);
 	if (dsPtr->string == dsPtr->staticSpace) {
-	    while (dsPtr->spaceAvl > newSize) {
-		newString = (char *)Tcl_AttemptAlloc(dsPtr->spaceAvl);
-		if (newString)
-		    break;
-		dsPtr->spaceAvl = TclUpsizeRetry(newSize, dsPtr->spaceAvl);
-	    }
-	    if (newString == NULL) {
-		dsPtr->spaceAvl = newSize;
-		newString = (char *) Tcl_Alloc(dsPtr->spaceAvl);
-	    }
+	    char *newString;
+	    newString = (char *) TclOverAlloc(newSize, &dsPtr->spaceAvl);
 	    memcpy(newString, dsPtr->string, dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
@@ -2791,18 +2758,8 @@ Tcl_DStringAppendElement(
 		/* Source string is within this DString. Note offset */
 		offset = element - dsPtr->string;
 	    }
-	    while (dsPtr->spaceAvl > newSize) {
-		newString = (char *)Tcl_AttemptRealloc(dsPtr->string, dsPtr->spaceAvl);
-		if (newString)
-		    break;
-		dsPtr->spaceAvl = TclUpsizeRetry(newSize, dsPtr->spaceAvl);
-	    }
-	    if (newString == NULL) {
-		dsPtr->spaceAvl = newSize;
-		newString = (char *) Tcl_Realloc(dsPtr->string, dsPtr->spaceAvl);
-	    }
-
-	    dsPtr->string = newString;
+	    dsPtr->string = (char *) TclOverRealloc(
+		newSize, dsPtr->string, dsPtr->spaceAvl, &dsPtr->spaceAvl);
 	    if (offset >= 0) {
 		element = dsPtr->string + offset;
 	    }
@@ -2861,13 +2818,16 @@ Tcl_DStringSetLength(
 	 * would be wasteful to overallocate that buffer, so we just allocate
 	 * enough for the requested size plus the trailing null byte. In the
 	 * second case, we are growing the buffer incrementally, so we need
-	 * behavior similar to Tcl_DStringAppend. The requested length will
-	 * usually be a small delta above the current spaceAvl, so we'll end
-	 * up doubling the old size. This won't grow the buffer quite as
-	 * quickly, but it should be close enough.
+	 * behavior similar to Tcl_DStringAppend.
+	 * TODO - the above makes no sense to me. How does the code below
+	 * translate into distinguishing the two cases above? IMO, if caller
+	 * specifically sets the length, there is no cause for overallocation.
 	 */
 
-	newsize = dsPtr->spaceAvl * 2;
+	if (length >= TCL_SIZE_MAX) {
+	    Tcl_Panic("Tcl_Concat: max size of Tcl value exceeded");
+	}
+	newsize = TclUpsizeAlloc(dsPtr->spaceAvl, length + 1, TCL_SIZE_MAX);
 	if (length < newsize) {
 	    dsPtr->spaceAvl = newsize;
 	} else {
-- 
cgit v0.12


From 16a75f3cbf8ba7ab30d4f5f1adcd658269d9ae8c Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Fri, 19 May 2023 16:47:58 +0000
Subject: More refactoring into common code

---
 generic/tclBinary.c    |  29 ++----
 generic/tclCkalloc.c   | 238 ++++++++++++++++++++++++++++++-------------------
 generic/tclInt.h       |  43 ++++++---
 generic/tclListObj.c   |  61 +++++--------
 generic/tclStringObj.c |  60 ++++++-------
 generic/tclUtil.c      |  12 +--
 6 files changed, 234 insertions(+), 209 deletions(-)

diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 4215913..81ea3f3 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -767,27 +767,14 @@ TclAppendBytesToByteArray(
     }
     needed = byteArrayPtr->used + len;
     if (needed > byteArrayPtr->allocated) {
-	ByteArray *ptr = NULL;
-	Tcl_Size attempt;
-
-        /* First try to overallocate, reducing overallocation on each fail */
-	attempt =
-	    TclUpsizeAlloc(byteArrayPtr->allocated, needed, BYTEARRAY_MAX_LEN);
-	while (attempt > needed) {
-	    ptr = (ByteArray *)Tcl_AttemptRealloc(byteArrayPtr,
-						  BYTEARRAY_SIZE(attempt));
-	    if (ptr)
-		break;
-	    attempt = TclUpsizeRetry(needed, attempt);
-	}
-
-	if (ptr == NULL) {
-	    /* Last chance: Try to allocate exactly what is needed. */
-	    attempt = needed;
-	    ptr = (ByteArray *)Tcl_Realloc(byteArrayPtr, BYTEARRAY_SIZE(attempt));
-	}
-	byteArrayPtr = ptr;
-	byteArrayPtr->allocated = attempt;
+	Tcl_Size newCapacity;
+	byteArrayPtr =
+	    (ByteArray *)TclReallocElemsEx(byteArrayPtr,
+					   needed,
+					   1,
+					   offsetof(ByteArray, bytes),
+					   &newCapacity);
+	byteArrayPtr->allocated = newCapacity;
 	SET_BYTEARRAY(irPtr, byteArrayPtr);
     }
 
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 1539f4f..6aabf9f 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -16,6 +16,7 @@
  */
 
 #include "tclInt.h"
+#include <assert.h>
 
 #define FALSE	0
 #define TRUE	1
@@ -1194,40 +1195,99 @@ Tcl_DbCkfree(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_InitMemory --
+ *
+ *	Dummy initialization for memory command, which is only available if
+ *	TCL_MEM_DEBUG is on.
+ *
+ *----------------------------------------------------------------------
+ */
+void
+Tcl_InitMemory(
+    TCL_UNUSED(Tcl_Interp *) /*interp*/)
+{
+}
+
+int
+Tcl_DumpActiveMemory(
+    TCL_UNUSED(const char *) /*fileName*/)
+{
+    return TCL_OK;
+}
+
+void
+Tcl_ValidateAllMemory(
+    TCL_UNUSED(const char *) /*file*/,
+    TCL_UNUSED(int) /*line*/)
+{
+}
+
+int
+TclDumpMemoryInfo(
+    TCL_UNUSED(void *),
+    TCL_UNUSED(int) /*flags*/)
+{
+    return 1;
+}
+
+#endif	/* TCL_MEM_DEBUG */
+
+/*
  *------------------------------------------------------------------------
  *
- * TclAttemptOverAlloc --
+ * TclAttemptAllocElemsEx --
  *
- *    Attempts to allocates memory of the requested size plus some more for
- *    future growth.
+ *    Attempts to allocate memory of the requested size plus some more for
+ *    future growth. The amount of allocation is adjusted depending on
+ *    on failure.
  *
  * Results:
- *    Pointer to allocated memory block which is at least as large
- *    as the requested size or NULL if allocation failed.
+ *    Pointer to allocated memory block which is at least large enough
+ *    to hold elemCount elements or NULL if allocation failed.
  *
  *------------------------------------------------------------------------
  */
 void *
-TclAttemptOverAlloc(
-	Tcl_Size needed,	/* Requested size */
-	Tcl_Size *allocatedPtr) /* OUTPUT: Actual allocation size is stored
-				   here if non-NULL. Only modified on success */
+TclAttemptAllocElemsEx(
+    Tcl_Size elemCount,     /* Allocation will store at least these many... */
+    Tcl_Size elemSize,	    /* ...elements of this size */
+    Tcl_Size leadSize,      /* Additional leading space in bytes */
+    Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
+			       here if non-NULL. Only modified on success */
 {
     void *ptr;
-    Tcl_Size attempt = TclUpsizeAlloc(0, needed, TCL_SIZE_MAX);
-    while (attempt > needed) {
-	ptr = Tcl_AttemptAlloc(attempt);
-	if (ptr)
+    Tcl_Size limit;
+    Tcl_Size attempt;
+
+    assert(elemCount > 0);
+    assert(elemSize > 0);
+    assert(elemSize < TCL_SIZE_MAX);
+    assert(leadSize > 0);
+    assert(leadSize < TCL_SIZE_MAX);
+
+    limit = (TCL_SIZE_MAX - leadSize) / elemSize;
+    if (elemCount > limit) {
+	return NULL;
+    }
+    /* Loop trying for extra space, reducing request each time */
+    attempt = TclUpsizeAlloc(0, elemCount, limit);
+    ptr = NULL;
+    while (attempt > elemCount) {
+	ptr = Tcl_AttemptAlloc(leadSize + attempt*elemSize);
+	if (ptr) {
 	    break;
-	attempt = TclUpsizeRetry(needed, attempt);
+	}
+	attempt = TclUpsizeRetry(elemCount, attempt);
     }
+    /* Try exact size as a last resort */
     if (ptr == NULL) {
-	/* Try exact size as a last resort */
-	attempt = needed;
-	ptr = Tcl_AttemptAlloc(attempt);
+	attempt = elemCount;
+	ptr = Tcl_AttemptAlloc(leadSize + attempt*elemSize);
     }
-    if (ptr && allocatedPtr) {
-	*allocatedPtr = attempt;
+    if (ptr && capacityPtr) {
+	*capacityPtr = attempt;
     }
     return ptr;
 }
@@ -1235,14 +1295,13 @@ TclAttemptOverAlloc(
 /*
  *------------------------------------------------------------------------
  *
- * TclOverAlloc --
+ * TclAllocElemsEx --
  *
- *    Allocates memory of the requested size plus some more for future
- *    growth.
+ *    See TclAttemptAllocElemsEx. This function differs in that it panics
+ *    on failure.
  *
  * Results:
- *    Non-NULL pointer to allocated memory block which is at least as large
- *    as the requested size.
+ *    Non-NULL pointer to allocated memory block.
  *
  * Side effects:
  *    Panics if memory of at least the requested size could not be
@@ -1251,11 +1310,20 @@ TclAttemptOverAlloc(
  *------------------------------------------------------------------------
  */
 void *
-TclOverAlloc(Tcl_Size needed, Tcl_Size *allocatedPtr)
+TclAllocElemsEx(
+    Tcl_Size elemCount,     /* Allocation will store at least these many... */
+    Tcl_Size elemSize,	    /* ...elements of this size */
+    Tcl_Size leadSize,      /* Additional leading space in bytes */
+    Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
+			       here if non-NULL. Only modified on success */
 {
-    void *ptr = TclAttemptOverAlloc(needed, allocatedPtr);
+    void *ptr = TclAttemptAllocElemsEx(
+	elemCount, elemSize, leadSize, capacityPtr);
     if (ptr == NULL) {
-	Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER "d bytes.", needed);
+	Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER
+		  "d elements of size %" TCL_SIZE_MODIFIER "d bytes.",
+		  elemCount,
+		  elemSize);
     }
     return ptr;
 }
@@ -1263,10 +1331,11 @@ TclOverAlloc(Tcl_Size needed, Tcl_Size *allocatedPtr)
 /*
  *------------------------------------------------------------------------
  *
- * TclAttemptOverRealloc --
+ * TclAttemptReallocElemsEx --
  *
  *    Attempts to reallocate memory of the requested size plus some more for
- *    future growth.
+ *    future growth. The amount of reallocation is adjusted depending on
+ *    on failure.
  *
  * Results:
  *    Pointer to allocated memory block which is at least as large
@@ -1275,28 +1344,45 @@ TclOverAlloc(Tcl_Size needed, Tcl_Size *allocatedPtr)
  *------------------------------------------------------------------------
  */
 void *
-TclAttemptOverRealloc(
-    Tcl_Size needed,        /* Requested size */
+TclAttemptReallocElemsEx(
     void *oldPtr,	    /* Pointer to memory block to reallocate */
-    Tcl_Size oldSize,       /* Old size if known, or 0 if unknown */
-    Tcl_Size *allocatedPtr) /* OUTPUT: Actual allocation size is stored
+    Tcl_Size elemCount,     /* Allocation will store at least these many... */
+    Tcl_Size elemSize,	    /* ...elements of this size */
+    Tcl_Size leadSize,      /* Additional leading space in bytes */
+    Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
 			       here if non-NULL. Only modified on success */
 {
     void *ptr;
-    Tcl_Size attempt = TclUpsizeAlloc(oldSize, needed, TCL_SIZE_MAX);
-    while (attempt > needed) {
-	ptr = Tcl_AttemptRealloc(oldPtr, attempt);
-	if (ptr)
+    Tcl_Size limit;
+    Tcl_Size attempt;
+
+    assert(elemCount > 0);
+    assert(elemSize > 0);
+    assert(elemSize < TCL_SIZE_MAX);
+    assert(leadSize > 0);
+    assert(leadSize < TCL_SIZE_MAX);
+
+    limit = (TCL_SIZE_MAX - leadSize) / elemSize;
+    if (elemCount > limit) {
+	return NULL;
+    }
+    /* Loop trying for extra space, reducing request each time */
+    attempt = TclUpsizeAlloc(0, elemCount, limit);
+    ptr = NULL;
+    while (attempt > elemCount) {
+	ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt*elemSize);
+	if (ptr) {
 	    break;
-	attempt = TclUpsizeRetry(needed, attempt);
+	}
+	attempt = TclUpsizeRetry(elemCount, attempt);
     }
+    /* Try exact size as a last resort */
     if (ptr == NULL) {
-	/* Try exact size as a last resort */
-	attempt = needed;
-	ptr = Tcl_AttemptRealloc(oldPtr, attempt);
+	attempt = elemCount;
+	ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt*elemSize);
     }
-    if (ptr && allocatedPtr) {
-	*allocatedPtr = attempt;
+    if (ptr && capacityPtr) {
+	*capacityPtr = attempt;
     }
     return ptr;
 }
@@ -1304,14 +1390,13 @@ TclAttemptOverRealloc(
 /*
  *------------------------------------------------------------------------
  *
- * TclOverRealloc --
+ * TclReallocElemsEx --
  *
- *    Reallocates memory of the requested size plus some more for future
- *    growth.
+ *    See TclAttemptReallocElemsEx. This function differs in that it panics
+ *    on failure.
  *
  * Results:
- *    Non-NULL pointer to allocated memory block which is at least as large
- *    as the requested size.
+ *    Non-NULL pointer to allocated memory block.
  *
  * Side effects:
  *    Panics if memory of at least the requested size could not be
@@ -1320,61 +1405,26 @@ TclAttemptOverRealloc(
  *------------------------------------------------------------------------
  */
 void *
-TclOverRealloc(
-    Tcl_Size needed,        /* Requested size */
+TclReallocElemsEx(
     void *oldPtr,	    /* Pointer to memory block to reallocate */
-    Tcl_Size oldSize,       /* Old size if known, or 0 if unknown */
-    Tcl_Size *allocatedPtr) /* OUTPUT: Actual allocation size is stored
+    Tcl_Size elemCount,     /* Allocation will store at least these many... */
+    Tcl_Size elemSize,	    /* ...elements of this size */
+    Tcl_Size leadSize,      /* Additional leading space in bytes */
+    Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
 			       here if non-NULL. Only modified on success */
 {
-    void *ptr = TclAttemptOverRealloc(needed, oldPtr, oldSize, allocatedPtr);
+    void *ptr = TclAttemptReallocElemsEx(
+	oldPtr, elemCount, elemSize, leadSize, capacityPtr);
     if (ptr == NULL) {
-	Tcl_Panic("Failed to reallocate %" TCL_SIZE_MODIFIER "d bytes.", needed);
+	Tcl_Panic("Failed to reallocate %" TCL_SIZE_MODIFIER
+		  "d elements of size %" TCL_SIZE_MODIFIER "d bytes.",
+		  elemCount,
+		  elemSize);
     }
     return ptr;
 }
 
 /*
- *----------------------------------------------------------------------
- *
- * Tcl_InitMemory --
- *
- *	Dummy initialization for memory command, which is only available if
- *	TCL_MEM_DEBUG is on.
- *
- *----------------------------------------------------------------------
- */
-void
-Tcl_InitMemory(
-    TCL_UNUSED(Tcl_Interp *) /*interp*/)
-{
-}
-
-int
-Tcl_DumpActiveMemory(
-    TCL_UNUSED(const char *) /*fileName*/)
-{
-    return TCL_OK;
-}
-
-void
-Tcl_ValidateAllMemory(
-    TCL_UNUSED(const char *) /*file*/,
-    TCL_UNUSED(int) /*line*/)
-{
-}
-
-int
-TclDumpMemoryInfo(
-    TCL_UNUSED(void *),
-    TCL_UNUSED(int) /*flags*/)
-{
-    return 1;
-}
-
-#endif	/* TCL_MEM_DEBUG */
-
-/*
  *---------------------------------------------------------------------------
  *
  * TclFinalizeMemorySubsystem --
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 56bef02..5a7c397 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2873,18 +2873,19 @@ typedef struct ProcessGlobalValue {
 
 /*
  *----------------------------------------------------------------------
- * Common functions for growing allocations. Trivial but allows for
+ * Common functions for calculating overallocation. Trivial but allows for
  * experimenting with growth factors without having to change code in
- * multiple places. See TclAttemptOverAlloc and TclAttemptOverRealloc for
- * usage examples. Best to use those functions if allocating in bytes.
- * Direct use of TclUpsizeAlloc / TclResizeAlloc is needed if allocating in other 
- * units (say Tcl_UniChar), if there is a fixed size header involved or if
- * the max limit is something other than TCL_SIZE_MAX.
+ * multiple places. See TclAttemptAllocElemsEx and similar for usage
+ * examples. Best to use those functions. Direct use of TclUpsizeAlloc /
+ * TclResizeAlloc is needed in special cases such as when total size of
+ * memory block is limited to less than TCL_SIZE_MAX.
  *
  *----------------------------------------------------------------------
  */
 static inline Tcl_Size
-TclUpsizeAlloc(TCL_UNUSED(Tcl_Size) /*oldSize*/,
+TclUpsizeAlloc(TCL_UNUSED(Tcl_Size) /* oldSize. For future experiments with
+				     * some growth algorithms that use this
+				     * information. */,
 	       Tcl_Size needed,
 	       Tcl_Size limit)
 {
@@ -2905,12 +2906,28 @@ static inline Tcl_Size TclUpsizeRetry(Tcl_Size needed, Tcl_Size lastAttempt) {
 	return needed;
     }
 }
-MODULE_SCOPE void *TclOverAlloc(Tcl_Size needed, Tcl_Size *allocatedPtr);
-MODULE_SCOPE void *TclAttemptOverAlloc(Tcl_Size needed, Tcl_Size *allocatedPtr);
-MODULE_SCOPE void *TclOverRealloc(Tcl_Size needed, void *oldPtr,
-			Tcl_Size oldSize, Tcl_Size *allocatedPtr);
-MODULE_SCOPE void *TclAttemptOverRealloc(Tcl_Size needed, void *oldPtr,
-			Tcl_Size oldSize, Tcl_Size *allocatedPtr);
+MODULE_SCOPE void *TclAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
+			Tcl_Size leadSize, Tcl_Size *capacityPtr);
+MODULE_SCOPE void *TclAttemptAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
+			Tcl_Size leadSize, Tcl_Size *capacityPtr);
+MODULE_SCOPE void *TclReallocElemsEx(void *oldPtr, Tcl_Size elemCount,
+			Tcl_Size elemSize, Tcl_Size leadSize, 
+			Tcl_Size *capacityPtr);
+MODULE_SCOPE void *TclAttemptReallocElemsEx(void *oldPtr,
+			Tcl_Size elemCount, Tcl_Size elemSize,
+			Tcl_Size leadSize, Tcl_Size *capacityPtr);
+static inline void *TclAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) {
+    return TclAllocElemsEx(numBytes, 1, 0, capacityPtr);
+}
+static inline void *TclAttemptAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) {
+    return TclAttemptAllocElemsEx(numBytes, 1, 0, capacityPtr);
+}
+static inline void *TclReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) {
+    return TclReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
+}
+static inline void *TclAttemptReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) {
+    return TclAttemptReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
+}
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 4c7849d..c8464d5 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -748,29 +748,20 @@ ListStoreNew(
     storePtr = NULL;
     if (flags & LISTREP_SPACE_FLAGS) {
 	/* Caller requests extra space front, back or both */
-	capacity = TclUpsizeAlloc(0, objc, LIST_MAX);
-	while (capacity > objc) {
-	    storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
-	    if (storePtr)
-		break;
-	    capacity = TclUpsizeRetry(0, capacity);
-	}
+	storePtr = (ListStore *)TclAttemptAllocElemsEx(
+	    objc, sizeof(Tcl_Obj *), offsetof(ListStore, slots), &capacity);
     } else {
 	/* Exact allocation */
 	capacity = objc;
+	storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
     }
     if (storePtr == NULL) {
-	/* Either overallocation failed or exact allocation */
-	storePtr = (ListStore *)Tcl_AttemptAlloc(LIST_SIZE(capacity));
-	if (storePtr == NULL) {
-	    if (flags & LISTREP_PANIC_ON_FAIL) {
-		Tcl_Panic(
-		    "list creation failed: unable to alloc %" TCL_Z_MODIFIER
-		    "u bytes",
-		    LIST_SIZE(objc));
-	    }
-	    return NULL;
+	if (flags & LISTREP_PANIC_ON_FAIL) {
+	    Tcl_Panic("list creation failed: unable to alloc %" TCL_Z_MODIFIER
+		      "u bytes",
+		      LIST_SIZE(objc));
 	}
+	return NULL;
     }
 
     storePtr->refCount = 0;
@@ -829,33 +820,23 @@ ListStoreNew(
 ListStore *
 ListStoreReallocate (ListStore *storePtr, Tcl_Size needed)
 {
-    Tcl_Size attempt;
-    ListStore *newStorePtr;
-
-    /* First try to overallocate, reducing overallocation on each fail */
-    newStorePtr = NULL;
-    attempt = TclUpsizeAlloc(storePtr->numAllocated, needed, LIST_MAX);
-    while (attempt > needed) {
-	newStorePtr =
-	    (ListStore *)Tcl_AttemptRealloc(storePtr, LIST_SIZE(attempt));
-	if (newStorePtr)
-	    break;
-	attempt = TclUpsizeRetry(needed, attempt);
-    }
+    Tcl_Size capacity;
 
-    if (newStorePtr == NULL) {
-	/* Last resort - allcate what was asked */
-	attempt = needed;
-	newStorePtr = (ListStore *)Tcl_AttemptRealloc(storePtr,
-						    LIST_SIZE(attempt));
-	if (newStorePtr == NULL)
-	    return NULL;
+    if (needed > LIST_MAX) {
+	return NULL;
     }
+    storePtr = (ListStore *)TclAttemptReallocElemsEx(storePtr,
+						     needed,
+						     sizeof(Tcl_Obj *),
+						     offsetof(ListStore, slots),
+						     &capacity);
     /* Only the capacity has changed, fix it in the header */
-    newStorePtr->numAllocated = attempt;
-    return newStorePtr;
+    if (storePtr) {
+	storePtr->numAllocated = capacity;
+    }
+    return storePtr;
 }
-
+
 /*
  *----------------------------------------------------------------------
  *
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 6553810..b846320 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -143,7 +143,7 @@ GrowStringBuffer(
 
     String *stringPtr = GET_STRING(objPtr);
     char *ptr;
-    Tcl_Size attempt;
+    Tcl_Size capacity;
 
     assert(needed <= TCL_SIZE_MAX - 1);
     needed += 1; /* Include terminating nul */
@@ -152,27 +152,20 @@ GrowStringBuffer(
 	objPtr->bytes = NULL;
     }
     /* 
-     * In code below, note 'attempt' and 'needed' include terminating nul,
+     * In code below, note 'capacity' and 'needed' include terminating nul,
      * while stringPtr->allocated does not.
      */
-    ptr = NULL;
     if (flag == 0 || stringPtr->allocated > 0) {
-	attempt =
-	    TclUpsizeAlloc(stringPtr->allocated + 1, needed, TCL_SIZE_MAX);
-	while (attempt > needed) {
-	    ptr = (char *)Tcl_AttemptRealloc(objPtr->bytes, attempt);
-	    if (ptr)
-		break;
-	    attempt = TclUpsizeRetry(needed, attempt);
-	}
+	ptr = (char *)TclReallocEx(objPtr->bytes, needed, &capacity);
     }
-    if (ptr == NULL) {
-	/* First allocation - just big enough; or last chance fallback. */
-	attempt = needed;
-	ptr = (char *)Tcl_Realloc(objPtr->bytes, attempt);
+    else {
+	/* Allocate exact size */
+	ptr = (char *)Tcl_Realloc(objPtr->bytes, needed);
+	capacity = needed;
     }
+
     objPtr->bytes = ptr;
-    stringPtr->allocated = attempt - 1; /* Does not include slot for end nul */
+    stringPtr->allocated = capacity - 1; /* Does not include slot for end nul */
 }
 
 static void
@@ -186,32 +179,29 @@ GrowUnicodeBuffer(
      *	needed > stringPtr->maxChars
      */
 
-    String *ptr, *stringPtr = GET_STRING(objPtr);
-    Tcl_Size attempt;
+    String *stringPtr = GET_STRING(objPtr);
+    Tcl_Size maxChars;
 
     /* Note STRING_MAXCHARS already takes into account space for nul */
     if (needed > STRING_MAXCHARS) {
 	Tcl_Panic("max size for a Tcl unicode rep (%" TCL_Z_MODIFIER "d bytes) exceeded",
 		  STRING_MAXCHARS);
     }
-    ptr = NULL;
     if (stringPtr->maxChars > 0) {
-	/* Subsequent appends - apply the growth algorithm. */
-	attempt = TclUpsizeAlloc(stringPtr->maxChars, needed, STRING_MAXCHARS);
-	while (attempt > needed) {
-	    ptr = (String *)Tcl_AttemptRealloc(stringPtr, STRING_SIZE(attempt));
-	    if (ptr)
-		break;
-	    attempt = TclUpsizeRetry(needed, attempt);
-	}
-    }
-    if (ptr == NULL) {
-	/* First allocation - just big enough; or last chance fallback. */
-	attempt = needed;
-	ptr = (String *)Tcl_Realloc(stringPtr, STRING_SIZE(attempt));
-    }
-    stringPtr = ptr;
-    stringPtr->maxChars = attempt;
+	/* Expansion - try allocating extra space */
+	stringPtr = (String *)TclReallocElemsEx(stringPtr,
+						needed + 1, /* +1 for nul */
+						sizeof(Tcl_UniChar),
+						offsetof(String, unicode),
+						&maxChars);
+	maxChars -= 1; /* End nul not included */
+    }
+    else {
+	/* First allocation - just big enough */
+	stringPtr = (String *)Tcl_Realloc(stringPtr, STRING_SIZE(needed));
+	maxChars = needed;
+    }
+    stringPtr->maxChars = maxChars;
     SET_STRING(objPtr, stringPtr);
 }
 
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index e8cd164..046ba00 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2615,7 +2615,7 @@ Tcl_DStringAppend(
     if (newSize > dsPtr->spaceAvl) {
 	if (dsPtr->string == dsPtr->staticSpace) {
 	    char *newString;
-	    newString = (char *) TclOverAlloc(newSize, &dsPtr->spaceAvl);
+	    newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl);
 	    memcpy(newString, dsPtr->string, dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
@@ -2627,8 +2627,8 @@ Tcl_DStringAppend(
 		/* Source string is within this DString. Note offset */
 		offset = bytes - dsPtr->string;
 	    }
-	    dsPtr->string = (char *) TclOverRealloc(
-		newSize, dsPtr->string, dsPtr->spaceAvl, &dsPtr->spaceAvl);
+	    dsPtr->string =
+		(char *)TclReallocEx(dsPtr->string, newSize, &dsPtr->spaceAvl);
 	    if (offset >= 0) {
 		bytes = dsPtr->string + offset;
 	    }
@@ -2746,7 +2746,7 @@ Tcl_DStringAppendElement(
     if (newSize > dsPtr->spaceAvl) {
 	if (dsPtr->string == dsPtr->staticSpace) {
 	    char *newString;
-	    newString = (char *) TclOverAlloc(newSize, &dsPtr->spaceAvl);
+	    newString = (char *) TclAllocEx(newSize, &dsPtr->spaceAvl);
 	    memcpy(newString, dsPtr->string, dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
@@ -2758,8 +2758,8 @@ Tcl_DStringAppendElement(
 		/* Source string is within this DString. Note offset */
 		offset = element - dsPtr->string;
 	    }
-	    dsPtr->string = (char *) TclOverRealloc(
-		newSize, dsPtr->string, dsPtr->spaceAvl, &dsPtr->spaceAvl);
+	    dsPtr->string =
+		(char *)TclReallocEx(dsPtr->string, newSize, &dsPtr->spaceAvl);
 	    if (offset >= 0) {
 		element = dsPtr->string + offset;
 	    }
-- 
cgit v0.12


From 96d441c29a2a47269655285a02c546765c163fd2 Mon Sep 17 00:00:00 2001
From: apnadkarni <apnmbx-wits@yahoo.com>
Date: Sat, 20 May 2023 15:40:17 +0000
Subject: Minor refactor to combine alloc/realloc

---
 generic/tclCkalloc.c   | 84 +++++++++++---------------------------------------
 generic/tclInt.h       | 17 ++++++++--
 generic/tclStringObj.c |  8 +++--
 3 files changed, 37 insertions(+), 72 deletions(-)

diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 6aabf9f..106a62c 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -1237,64 +1237,6 @@ TclDumpMemoryInfo(
 /*
  *------------------------------------------------------------------------
  *
- * TclAttemptAllocElemsEx --
- *
- *    Attempts to allocate memory of the requested size plus some more for
- *    future growth. The amount of allocation is adjusted depending on
- *    on failure.
- *
- * Results:
- *    Pointer to allocated memory block which is at least large enough
- *    to hold elemCount elements or NULL if allocation failed.
- *
- *------------------------------------------------------------------------
- */
-void *
-TclAttemptAllocElemsEx(
-    Tcl_Size elemCount,     /* Allocation will store at least these many... */
-    Tcl_Size elemSize,	    /* ...elements of this size */
-    Tcl_Size leadSize,      /* Additional leading space in bytes */
-    Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
-			       here if non-NULL. Only modified on success */
-{
-    void *ptr;
-    Tcl_Size limit;
-    Tcl_Size attempt;
-
-    assert(elemCount > 0);
-    assert(elemSize > 0);
-    assert(elemSize < TCL_SIZE_MAX);
-    assert(leadSize > 0);
-    assert(leadSize < TCL_SIZE_MAX);
-
-    limit = (TCL_SIZE_MAX - leadSize) / elemSize;
-    if (elemCount > limit) {
-	return NULL;
-    }
-    /* Loop trying for extra space, reducing request each time */
-    attempt = TclUpsizeAlloc(0, elemCount, limit);
-    ptr = NULL;
-    while (attempt > elemCount) {
-	ptr = Tcl_AttemptAlloc(leadSize + attempt*elemSize);
-	if (ptr) {
-	    break;
-	}
-	attempt = TclUpsizeRetry(elemCount, attempt);
-    }
-    /* Try exact size as a last resort */
-    if (ptr == NULL) {
-	attempt = elemCount;
-	ptr = Tcl_AttemptAlloc(leadSize + attempt*elemSize);
-    }
-    if (ptr && capacityPtr) {
-	*capacityPtr = attempt;
-    }
-    return ptr;
-}
-
-/*
- *------------------------------------------------------------------------
- *
  * TclAllocElemsEx --
  *
  *    See TclAttemptAllocElemsEx. This function differs in that it panics
@@ -1317,8 +1259,8 @@ TclAllocElemsEx(
     Tcl_Size *capacityPtr) /* OUTPUT: Actual capacity is stored
 			       here if non-NULL. Only modified on success */
 {
-    void *ptr = TclAttemptAllocElemsEx(
-	elemCount, elemSize, leadSize, capacityPtr);
+    void *ptr = TclAttemptReallocElemsEx(
+	NULL, elemCount, elemSize, leadSize, capacityPtr);
     if (ptr == NULL) {
 	Tcl_Panic("Failed to allocate %" TCL_SIZE_MODIFIER
 		  "d elements of size %" TCL_SIZE_MODIFIER "d bytes.",
@@ -1333,9 +1275,10 @@ TclAllocElemsEx(
  *
  * TclAttemptReallocElemsEx --
  *
- *    Attempts to reallocate memory of the requested size plus some more for
- *    future growth. The amount of reallocation is adjusted depending on
- *    on failure.
+ *    Attempts to allocate (oldPtr == NULL) or reallocate memory of the
+ *    requested size plus some more for future growth. The amount of
+ *    reallocation is adjusted depending on on failure.
+ * 
  *
  * Results:
  *    Pointer to allocated memory block which is at least as large
@@ -1345,7 +1288,8 @@ TclAllocElemsEx(
  */
 void *
 TclAttemptReallocElemsEx(
-    void *oldPtr,	    /* Pointer to memory block to reallocate */
+    void *oldPtr,	    /* Pointer to memory block to reallocate or 
+			     * NULL to indicate this is a new allocation */
     Tcl_Size elemCount,     /* Allocation will store at least these many... */
     Tcl_Size elemSize,	    /* ...elements of this size */
     Tcl_Size leadSize,      /* Additional leading space in bytes */
@@ -1370,7 +1314,11 @@ TclAttemptReallocElemsEx(
     attempt = TclUpsizeAlloc(0, elemCount, limit);
     ptr = NULL;
     while (attempt > elemCount) {
-	ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt*elemSize);
+	if (oldPtr) {
+	    ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt * elemSize);
+	} else {
+	    ptr = Tcl_AttemptAlloc(leadSize + attempt * elemSize);
+	}
 	if (ptr) {
 	    break;
 	}
@@ -1379,7 +1327,11 @@ TclAttemptReallocElemsEx(
     /* Try exact size as a last resort */
     if (ptr == NULL) {
 	attempt = elemCount;
-	ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt*elemSize);
+	if (oldPtr) {
+	    ptr = Tcl_AttemptRealloc(oldPtr, leadSize + attempt * elemSize);
+	} else {
+	    ptr = Tcl_AttemptAlloc(leadSize + attempt * elemSize);
+	}
     }
     if (ptr && capacityPtr) {
 	*capacityPtr = attempt;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f2123b5..bf42f6a 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2909,23 +2909,34 @@ static inline Tcl_Size TclUpsizeRetry(Tcl_Size needed, Tcl_Size lastAttempt) {
 }
 MODULE_SCOPE void *TclAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
 			Tcl_Size leadSize, Tcl_Size *capacityPtr);
-MODULE_SCOPE void *TclAttemptAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
-			Tcl_Size leadSize, Tcl_Size *capacityPtr);
 MODULE_SCOPE void *TclReallocElemsEx(void *oldPtr, Tcl_Size elemCount,
 			Tcl_Size elemSize, Tcl_Size leadSize, 
 			Tcl_Size *capacityPtr);
 MODULE_SCOPE void *TclAttemptReallocElemsEx(void *oldPtr,
 			Tcl_Size elemCount, Tcl_Size elemSize,
 			Tcl_Size leadSize, Tcl_Size *capacityPtr);
+/* Alloc elemCount elements of size elemSize with leadSize header
+ * returning actual capacity (in elements) in *capacityPtr. */
+static inline void *TclAttemptAllocElemsEx(Tcl_Size elemCount, Tcl_Size elemSize,
+			Tcl_Size leadSize, Tcl_Size *capacityPtr) {
+    return TclAttemptReallocElemsEx(
+	NULL, elemCount, elemSize, leadSize, capacityPtr);
+}
+/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */
 static inline void *TclAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) {
     return TclAllocElemsEx(numBytes, 1, 0, capacityPtr);
 }
-static inline void *TclAttemptAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr) {
+/* Alloc numByte bytes, returning actual capacity in *capacityPtr. */
+static inline void *
+TclAttemptAllocEx(Tcl_Size numBytes, Tcl_Size *capacityPtr)
+{
     return TclAttemptAllocElemsEx(numBytes, 1, 0, capacityPtr);
 }
+/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */
 static inline void *TclReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) {
     return TclReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
 }
+/* Realloc numByte bytes, returning actual capacity in *capacityPtr. */
 static inline void *TclAttemptReallocEx(void *oldPtr, Tcl_Size numBytes, Tcl_Size *capacityPtr) {
     return TclAttemptReallocElemsEx(oldPtr, numBytes, 1, 0, capacityPtr);
 }
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 0da5f04..5864ebc 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -157,8 +157,7 @@ GrowStringBuffer(
      */
     if (flag == 0 || stringPtr->allocated > 0) {
 	ptr = (char *)TclReallocEx(objPtr->bytes, needed, &capacity);
-    }
-    else {
+    } else {
 	/* Allocate exact size */
 	ptr = (char *)Tcl_Realloc(objPtr->bytes, needed);
 	capacity = needed;
@@ -197,7 +196,10 @@ GrowUnicodeBuffer(
 	maxChars -= 1; /* End nul not included */
     }
     else {
-	/* First allocation - just big enough */
+	/* 
+	 * First allocation - just big enough. Note needed does
+	 * not include terminating nul but STRING_SIZE does
+	 */
 	stringPtr = (String *)Tcl_Realloc(stringPtr, STRING_SIZE(needed));
 	maxChars = needed;
     }
-- 
cgit v0.12