Tcl Source Code

Check-in [820ba0e29a]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:
* generic/tclStringObj.c: Factor out common GrowStringBuffer().
* generic/tclStringObj.c: Convert Tcl_AppendStringsToObj into * tests/stringObj.test: a radically simpler implementation where we just loop over calls to Tcl_AppendToObj. This fixes [Bug 2597185]. It also creates a *** POTENTIAL INCOMPATIBILITY *** in that T_ASTO can now allocate more space than is strictly required, like all the other Tcl_Append* routines. The incompatibility was detected by test stringObj-6.5, which I've updated to reflect the new behavior.
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk | potential incompatibility
Files: files | file ages | folders
SHA1: 820ba0e29a10df3d23fcd8e05771b3da80b0957c
User & Date: dgp 2009-02-17 17:17:32
Context
2009-02-17
18:10
* win/tcl.m4, win/configure: Check if cl groks _WIN64 already to avoid CC manipulation that can sc...
check-in: e587ee7ca9 user: hobbs tags: trunk
17:17
* generic/tclStringObj.c: Factor out common GrowStringBuffer().
* generic/tcl...
check-in: 820ba0e29a user: dgp tags: trunk, potential incompatibility
06:52
* generic/tclStringObj.c: Revise buffer growth implementation in ExtendStringR...
check-in: e188de7032 user: dgp tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to ChangeLog.

     1      1   2009-02-17  Don Porter  <[email protected]t>
            2  +
            3  +	* generic/tclStringObj.c:	Factor out common GrowStringBuffer().
            4  +
            5  +	* generic/tclStringObj.c:	Convert Tcl_AppendStringsToObj into
            6  +	* tests/stringObj.test:		a radically simpler implementation
            7  +	where we just loop over calls to Tcl_AppendToObj.  This fixes [Bug
            8  +	2597185].  It also creates a *** POTENTIAL INCOMPATIBILITY *** in
            9  +	that T_ASTO can now allocate more space than is strictly required,
           10  +	like all the other Tcl_Append* routines.  The incompatibility was
           11  +	detected by test stringObj-6.5, which I've updated to reflect the
           12  +	new behavior.
     2     13   
     3     14   	* generic/tclStringObj.c:	Revise buffer growth implementation
     4     15   	in ExtendStringRepWithUnicode.  Use cheap checks to determine that
     5     16   	no reallocation is necessary without cost of computing the precise
     6     17   	number of bytes needed.  Also make use of the string growth algortihm
     7     18   	in the case of repeated appends.
     8     19   

Changes to generic/tclStringObj.c.

    29     29    *
    30     30    * Copyright (c) 1995-1997 Sun Microsystems, Inc.
    31     31    * Copyright (c) 1999 by Scriptics Corporation.
    32     32    *
    33     33    * See the file "license.terms" for information on usage and redistribution of
    34     34    * this file, and for a DISCLAIMER OF ALL WARRANTIES.
    35     35    *
    36         - * RCS: @(#) $Id: tclStringObj.c,v 1.110 2009/02/17 06:52:05 dgp Exp $ */
           36  + * RCS: @(#) $Id: tclStringObj.c,v 1.111 2009/02/17 17:17:32 dgp Exp $ */
    37     37   
    38     38   #include "tclInt.h"
    39     39   #include "tommath.h"
    40     40   
    41     41   /*
    42     42    * Prototypes for functions defined later in this file:
    43     43    */
................................................................................
    57     57   static int		ExtendStringRepWithUnicode(Tcl_Obj *objPtr,
    58     58   			    const Tcl_UniChar *unicode, int numChars);
    59     59   static void		ExtendUnicodeRepWithString(Tcl_Obj *objPtr,
    60     60   			    const char *bytes, int numBytes,
    61     61   			    int numAppendChars);
    62     62   static void		FillUnicodeRep(Tcl_Obj *objPtr);
    63     63   static void		FreeStringInternalRep(Tcl_Obj *objPtr);
           64  +static void		GrowStringBuffer(Tcl_Obj *objPtr, int needed, int flag);
    64     65   static int		SetStringFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
    65     66   static void		SetUnicodeObj(Tcl_Obj *objPtr,
    66     67   			    const Tcl_UniChar *unicode, int numChars);
    67     68   static int		UnicodeLength(const Tcl_UniChar *unicode);
    68     69   static void		UpdateStringOfString(Tcl_Obj *objPtr);
    69     70   
    70     71   /*
................................................................................
   185    186    *				the double allocation has failed. Default is
   186    187    *				1024 (1 kilobyte).
   187    188    */
   188    189   
   189    190   #ifndef TCL_GROWTH_MIN_ALLOC
   190    191   #define TCL_GROWTH_MIN_ALLOC	1024
   191    192   #endif
          193  +
          194  +static void
          195  +GrowStringBuffer(
          196  +    Tcl_Obj *objPtr,
          197  +    int needed,
          198  +    int flag)
          199  +{
          200  +    /* Pre-conditions: 
          201  +     *	objPtr->typePtr == &tclStringType
          202  +     *	needed > stringPtr->allocated
          203  +     *	flag || objPtr->bytes != NULL
          204  +     */
          205  +    String *stringPtr = GET_STRING(objPtr);
          206  +
          207  +    if (flag && stringPtr->allocated == 0) {
          208  +	/* First allocation - just big enough */
          209  +	if (objPtr->bytes == tclEmptyStringRep) {
          210  +	    objPtr->bytes = ckalloc((unsigned) needed + 1);
          211  +	} else {
          212  +	    objPtr->bytes = ckrealloc(objPtr->bytes, (unsigned) needed + 1);
          213  +	}
          214  +	stringPtr->allocated = needed;
          215  +    } else {
          216  +	/* Subsequent appends - apply the growth algorithm. */
          217  +	if (Tcl_AttemptSetObjLength(objPtr, 2 * needed) == 0) {
          218  +	    /*
          219  +	     * Take care computing the amount of modest growth to avoid
          220  +	     * overflow into invalid argument values for Tcl_SetObjLength.
          221  +	     */
          222  +	    unsigned int limit = INT_MAX - needed;
          223  +	    unsigned int extra = needed - objPtr->length + TCL_GROWTH_MIN_ALLOC;
          224  +	    int growth = (int) ((extra > limit) ? limit : extra);
          225  +
          226  +	    Tcl_SetObjLength(objPtr, needed + growth);
          227  +	}
          228  +    }
          229  +}
   192    230   
   193    231   /*
   194    232    *----------------------------------------------------------------------
   195    233    *
   196    234    * Tcl_NewStringObj --
   197    235    *
   198    236    *	This function is normally called when not debugging: i.e., when
................................................................................
  1484   1522       if (numBytes > INT_MAX - oldLength) {
  1485   1523   	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
  1486   1524       }
  1487   1525       newLength = numBytes + oldLength;
  1488   1526   
  1489   1527       stringPtr = GET_STRING(objPtr);
  1490   1528       if (newLength > stringPtr->allocated) {
  1491         -	/*
  1492         -	 * There isn't currently enough space in the string representation so
  1493         -	 * allocate additional space. First, try to double the length
  1494         -	 * required. If that fails, try a more modest allocation. See the "TCL
  1495         -	 * STRING GROWTH ALGORITHM" comment at the top of this file for an
  1496         -	 * explanation of this growth algorithm.
  1497         -	 */
  1498         -
  1499   1529   	/*
  1500   1530   	 * Protect against case where unicode points into the existing
  1501   1531   	 * stringPtr->unicode array.  Force it to follow any relocations
  1502   1532   	 * due to the reallocs below.
  1503   1533   	 */
  1504   1534   	int offset = -1;
  1505   1535   	if (bytes >= objPtr->bytes
  1506   1536   		&& bytes <= objPtr->bytes + objPtr->length) {
  1507   1537   	    offset = bytes - objPtr->bytes;
  1508   1538   	}
  1509   1539   
  1510         -	if (Tcl_AttemptSetObjLength(objPtr, 2 * newLength) == 0) {
  1511         -	    /*
  1512         -	     * Take care computing the amount of modest growth to avoid
  1513         -	     * overflow into invalid argument values for Tcl_SetObjLength.
  1514         -	     */
  1515         -	    unsigned int limit = INT_MAX - newLength;
  1516         -	    unsigned int extra = numBytes + TCL_GROWTH_MIN_ALLOC;
  1517         -	    int growth = (int) ((extra > limit) ? limit : extra);
  1518         -
  1519         -	    Tcl_SetObjLength(objPtr, newLength + growth);
  1520         -	}
         1540  +	/* TODO: consider passing flag=1: no overalloc on first append.
         1541  +	 * This would make test stringObj-8.1 fail.*/
         1542  +	GrowStringBuffer(objPtr, newLength, 0);
  1521   1543   
  1522   1544   	/* Relocate bytes if needed; see above. */
  1523   1545   	if (offset >= 0) {
  1524   1546   	    bytes = objPtr->bytes + offset;
  1525   1547   	}
  1526   1548       }
  1527   1549   
................................................................................
  1532   1554       stringPtr->numChars = -1;
  1533   1555       stringPtr->hasUnicode = 0;
  1534   1556   
  1535   1557       memcpy(objPtr->bytes + oldLength, bytes, numBytes);
  1536   1558       objPtr->bytes[newLength] = 0;
  1537   1559       objPtr->length = newLength;
  1538   1560   }
         1561  +
  1539   1562   
  1540   1563   /*
  1541   1564    *----------------------------------------------------------------------
  1542   1565    *
  1543   1566    * Tcl_AppendStringsToObjVA --
  1544   1567    *
  1545   1568    *	This function appends one or more null-terminated strings to an
................................................................................
  1556   1579    */
  1557   1580   
  1558   1581   void
  1559   1582   Tcl_AppendStringsToObjVA(
  1560   1583       Tcl_Obj *objPtr,		/* Points to the object to append to. */
  1561   1584       va_list argList)		/* Variable argument list. */
  1562   1585   {
  1563         -#define STATIC_LIST_SIZE 16
  1564         -    String *stringPtr;
  1565         -    int newLength, oldLength, attemptLength;
  1566         -    char *string, *dst;
  1567         -    char *static_list[STATIC_LIST_SIZE];
  1568         -    char **args = static_list;
  1569         -    int nargs_space = STATIC_LIST_SIZE;
  1570         -    int nargs, i;
  1571         -
  1572   1586       if (Tcl_IsShared(objPtr)) {
  1573   1587   	Tcl_Panic("%s called with shared object", "Tcl_AppendStringsToObj");
  1574   1588       }
  1575   1589   
  1576         -    SetStringFromAny(NULL, objPtr);
  1577         -
  1578         -    /*
  1579         -     * Figure out how much space is needed for all the strings, and expand the
  1580         -     * string representation if it isn't big enough. If no bytes would be
  1581         -     * appended, just return. Note that on some platforms (notably OS/390) the
  1582         -     * argList is an array so we need to use memcpy.
  1583         -     */
  1584         -
  1585         -    nargs = 0;
  1586         -    newLength = 0;
  1587         -    oldLength = objPtr->length;
  1588   1590       while (1) {
  1589         -	string = va_arg(argList, char *);
  1590         -	if (string == NULL) {
         1591  +	const char *bytes = va_arg(argList, char *);
         1592  +	if (bytes == NULL) {
  1591   1593   	    break;
  1592   1594   	}
  1593         -	if (nargs >= nargs_space) {
  1594         -	    /*
  1595         -	     * Expand the args buffer.
  1596         -	     */
  1597         -
  1598         -	    nargs_space += STATIC_LIST_SIZE;
  1599         -	    if (args == static_list) {
  1600         -		args = (void *) ckalloc(nargs_space * sizeof(char *));
  1601         -		for (i = 0; i < nargs; ++i) {
  1602         -		    args[i] = static_list[i];
  1603         -		}
  1604         -	    } else {
  1605         -		args = (void *) ckrealloc((void *) args,
  1606         -			nargs_space * sizeof(char *));
  1607         -	    }
  1608         -	}
  1609         -	newLength += strlen(string);
  1610         -	args[nargs++] = string;
         1595  +	Tcl_AppendToObj(objPtr, bytes, -1);
  1611   1596       }
  1612         -    if (newLength == 0) {
  1613         -	goto done;
  1614         -    }
  1615         -
  1616         -    stringPtr = GET_STRING(objPtr);
  1617         -    /* TODO: pure unicode will crash! */
  1618         -    if (oldLength + newLength > stringPtr->allocated) {
  1619         -	/*
  1620         -	 * There isn't currently enough space in the string representation, so
  1621         -	 * allocate additional space. If the current string representation
  1622         -	 * isn't empty (i.e. it looks like we're doing a series of appends)
  1623         -	 * then try to allocate extra space to accomodate future growth: first
  1624         -	 * try to double the required memory; if that fails, try a more modest
  1625         -	 * allocation. See the "TCL STRING GROWTH ALGORITHM" comment at the
  1626         -	 * top of this file for an explanation of this growth algorithm.
  1627         -	 * Otherwise, if the current string representation is empty, exactly
  1628         -	 * enough memory is allocated.
  1629         -	 */
  1630         -
  1631         -	if (oldLength == 0) {
  1632         -	    Tcl_SetObjLength(objPtr, newLength);
  1633         -	} else {
  1634         -	    attemptLength = 2 * (oldLength + newLength);
  1635         -	    if (Tcl_AttemptSetObjLength(objPtr, attemptLength) == 0) {
  1636         -		attemptLength = oldLength + (2 * newLength) +
  1637         -			TCL_GROWTH_MIN_ALLOC;
  1638         -		Tcl_SetObjLength(objPtr, attemptLength);
  1639         -	    }
  1640         -	}
  1641         -    }
  1642         -
  1643         -    /*
  1644         -     * Make a second pass through the arguments, appending all the strings to
  1645         -     * the object.
  1646         -     */
  1647         -
  1648         -    dst = objPtr->bytes + oldLength;
  1649         -    for (i = 0; i < nargs; ++i) {
  1650         -	string = args[i];
  1651         -	if (string == NULL) {
  1652         -	    break;
  1653         -	}
  1654         -	while (*string != 0) {
  1655         -	    *dst = *string;
  1656         -	    dst++;
  1657         -	    string++;
  1658         -	}
  1659         -    }
  1660         -
  1661         -    /*
  1662         -     * Add a null byte to terminate the string. However, be careful: it's
  1663         -     * possible that the object is totally empty (if it was empty originally
  1664         -     * and there was nothing to append). In this case dst is NULL; just leave
  1665         -     * everything alone.
  1666         -     */
  1667         -
  1668         -    if (dst != NULL) {
  1669         -	*dst = 0;
  1670         -    }
  1671         -    objPtr->length = oldLength + newLength;
  1672         -
  1673         -  done:
  1674         -    /*
  1675         -     * If we had to allocate a buffer from the heap, free it now.
  1676         -     */
  1677         -
  1678         -    if (args != static_list) {
  1679         -	ckfree((char *) args);
  1680         -    }
  1681         -#undef STATIC_LIST_SIZE
  1682   1597   }
  1683   1598   
  1684   1599   /*
  1685   1600    *----------------------------------------------------------------------
  1686   1601    *
  1687   1602    * Tcl_AppendStringsToObj --
  1688   1603    *
................................................................................
  2931   2846       }
  2932   2847       if (size < 0) {
  2933   2848   	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
  2934   2849       }
  2935   2850   
  2936   2851       /* Grow space if needed */
  2937   2852       if (size > stringPtr->allocated) {
  2938         -	if (stringPtr->allocated == 0) {
  2939         -	    /* First allocation - just big enough */
  2940         -	    objPtr->bytes = ckrealloc(objPtr->bytes, (unsigned) size+1);
  2941         -	    stringPtr->allocated = size;
  2942         -	} else {
  2943         -	    /* Subsequent appends - apply the growth algorithm. */
  2944         -	    if (Tcl_AttemptSetObjLength(objPtr, 2 * size) == 0) {
  2945         -		/*
  2946         -		 * Take care computing the amount of modest growth to avoid
  2947         -		 * overflow into invalid argument values for Tcl_SetObjLength.
  2948         -		 */
  2949         -		unsigned int limit = INT_MAX - size;
  2950         -		unsigned int extra = size - objPtr->length
  2951         -			+ TCL_GROWTH_MIN_ALLOC;
  2952         -		int growth = (int) ((extra > limit) ? limit : extra);
  2953         -
  2954         -		Tcl_SetObjLength(objPtr, size + growth);
  2955         -	    }
  2956         -	}
         2853  +	GrowStringBuffer(objPtr, size, 1);
  2957   2854       }
  2958   2855   
  2959   2856       copyBytes:
  2960   2857       dst = objPtr->bytes + origLength;
  2961   2858       for (i = 0; i < numChars; i++) {
  2962   2859   	dst += Tcl_UniCharToUtf((int) unicode[i], dst);
  2963   2860       }

Changes to tests/stringObj.test.

     8      8   #
     9      9   # Copyright (c) 1995-1997 Sun Microsystems, Inc.
    10     10   # Copyright (c) 1998-1999 by Scriptics Corporation.
    11     11   #
    12     12   # See the file "license.terms" for information on usage and redistribution of
    13     13   # this file, and for a DISCLAIMER OF ALL WARRANTIES.
    14     14   #
    15         -# RCS: @(#) $Id: stringObj.test,v 1.20 2009/02/16 04:33:10 dgp Exp $
           15  +# RCS: @(#) $Id: stringObj.test,v 1.21 2009/02/17 17:17:32 dgp Exp $
    16     16   
    17     17   if {[lsearch [namespace children] ::tcltest] == -1} {
    18     18       package require tcltest
    19     19       namespace import -force ::tcltest::*
    20     20   }
    21     21   
    22     22   testConstraint testobj [llength [info commands testobj]]
................................................................................
   132    132       list [teststringobj length 1] [teststringobj get 1]
   133    133   } {15 {abc 123 abcdefg}}
   134    134   test stringObj-6.5 {Tcl_AppendStringsToObj procedure, don't double space if initial string empty} testobj {
   135    135       testobj freeallvars
   136    136       testobj newobj 1
   137    137       teststringobj appendstrings 1 123 abcdefg
   138    138       list [teststringobj length 1] [teststringobj length2 1] [teststringobj get 1]
   139         -} {10 10 123abcdefg}
          139  +} {10 20 123abcdefg}
   140    140   test stringObj-6.6 {Tcl_AppendStringsToObj procedure, space reallocation} testobj {
   141    141       testobj freeallvars
   142    142       teststringobj set 1 abc
   143    143       teststringobj setlength 1 10
   144    144       teststringobj setlength 1 2
   145    145       teststringobj appendstrings 1 34567890
   146    146       list [teststringobj length 1] [teststringobj length2 1] \