From 9b718efb671760d88cc93cb84eaa73697691e517 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 1 Nov 2003 01:20:32 +0000 Subject: Increased robustness and speed for [lrepeat] with help of new list constructor --- ChangeLog | 13 ++++++ generic/tclCmdIL.c | 53 +++++++++++++++++------ generic/tclConfig.c | 95 +++++++++++++++++++---------------------- generic/tclInt.decls | 11 ++++- generic/tclInt.h | 5 ++- generic/tclListObj.c | 116 ++++++++++++++++++++++++++++++++++++++++++++++++++- 6 files changed, 225 insertions(+), 68 deletions(-) diff --git a/ChangeLog b/ChangeLog index 5e33cb0..936f9eb 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,16 @@ +2003-11-01 Donal K. Fellows + + * generic/tclCmdIL.c (Tcl_LrepeatObjCmd): Check for sensible list + lengths and allow for soft failure of the memory subsystem in the + [lconcat] command [Bug 829027]. Uses direct list creation to + avoid extra copies when working near the limit of available + memory. Also reorganized to encourage optimizing compilers to + optimize heavily. + * generic/tclListObj.c (TclNewListObjDirect): New list constructor + that does not copy the array of objects. Useful for creating + potentially very large lists or where you are about to throw away + the array argument which is being used in its entirety. + 2003-10-28 Miguel Sofer * generic/tclExecute.c (NEXT_INST macros): replaced macro variable diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c index c7b5e19..ec8dd4c 100644 --- a/generic/tclCmdIL.c +++ b/generic/tclCmdIL.c @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCmdIL.c,v 1.55 2003/10/15 13:15:45 dkf Exp $ + * RCS: @(#) $Id: tclCmdIL.c,v 1.56 2003/11/01 01:20:33 dkf Exp $ */ #include "tclInt.h" @@ -2650,7 +2650,7 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) register int objc; /* Number of arguments. */ register Tcl_Obj *CONST objv[]; /* The argument objects. */ { - int elementCount, i, j, k, result; + int elementCount, i, result; Tcl_Obj **dataArray; /* @@ -2685,22 +2685,50 @@ Tcl_LrepeatObjCmd(dummy, interp, objc, objv) * elementCount times. Note that we don't bother with stack * allocation for this, as we expect this function to be used * mainly when stack allocation would be inappropriate anyway. + * First check to see if we'd overflow and try to allocate an + * object larger than our memory allocator allows. Note that this + * is actually a fairly small value when you're on a serious + * 64-bit machine, but that requires API changes to fix. * - * POSSIBLE FUTURE ENHANCEMENT: Build the resulting list object - * directly and avoid a copy. + * We allocate using attemptckalloc() because if we ask for + * something big but can't get it, we've still got a high chance + * of having a proper failover strategy. If *that* fails to get + * memory, panic() will happen just a few lines lower... */ - dataArray = (Tcl_Obj **) ckalloc(elementCount * objc * sizeof(Tcl_Obj)); + if (elementCount > INT_MAX/sizeof(Tcl_Obj *)/objc) { + Tcl_AppendResult(interp, "overflow of maximum list length", NULL); + return TCL_ERROR; + } + + dataArray = (Tcl_Obj **) + attemptckalloc(elementCount * objc * sizeof(Tcl_Obj *)); + + if (dataArray == NULL) { + Tcl_AppendResult(interp, "insufficient memory to create list", NULL); + return TCL_ERROR; + } /* - * Set the elements. Note that this ends up setting k to the - * total number of elements. + * Set the elements. Note that we handle the common degenerate + * case of a single value being repeated separately to permit the + * compiler as much room as possible to optimize a loop that might + * be run a very large number of times. */ - k = 0; - for (i=0 ; i 3)) { @@ -220,61 +217,55 @@ QueryConfigObjCmd (clientData, interp, objc, objv) return TCL_ERROR; } - pDB = GetConfigDict (interp); - res = Tcl_DictObjGet (interp, pDB, pkgName, &pkgDict); - if ((res != TCL_OK) || (pkgDict == NULL)) { + pDB = GetConfigDict(interp); + res = Tcl_DictObjGet(interp, pDB, pkgName, &pkgDict); + if (res!=TCL_OK || pkgDict==NULL) { /* Maybe a panic is better, because the package data has to be present */ - Tcl_SetObjResult (interp, Tcl_NewStringObj ("package not known", -1)); + Tcl_SetObjResult(interp, Tcl_NewStringObj("package not known", -1)); return TCL_ERROR; } switch ((enum subcmds) index) { - case CFG_GET: - if (objc != 3) { - Tcl_WrongNumArgs (interp, 0, NULL, "get key"); - return TCL_ERROR; - } - - res = Tcl_DictObjGet (interp, pkgDict, objv [2], &val); - if ((res != TCL_OK) || (val == NULL)) { - Tcl_SetObjResult (interp, Tcl_NewStringObj ("key not known", -1)); - return TCL_ERROR; - } - - Tcl_SetObjResult (interp, val); - return TCL_OK; + case CFG_GET: + if (objc != 3) { + Tcl_WrongNumArgs(interp, 0, NULL, "get key"); + return TCL_ERROR; + } + res = Tcl_DictObjGet(interp, pkgDict, objv [2], &val); + if (res!=TCL_OK || val==NULL) { + Tcl_SetObjResult(interp, Tcl_NewStringObj("key not known", -1)); + return TCL_ERROR; + } - case CFG_LIST: - if (objc != 2) { - Tcl_WrongNumArgs (interp, 0, NULL, "list"); - return TCL_ERROR; - } + Tcl_SetObjResult(interp, val); + return TCL_OK; - Tcl_DictObjSize (interp, pkgDict, &n); - if (n == 0) { - Tcl_SetObjResult (interp, Tcl_NewListObj (0, NULL)); - return TCL_OK; - } + case CFG_LIST: + if (objc != 2) { + Tcl_WrongNumArgs(interp, 0, NULL, "list"); + return TCL_ERROR; + } - vals = (Tcl_Obj**) ckalloc (n * sizeof (Tcl_Obj*)); + Tcl_DictObjSize(interp, pkgDict, &n); + if (n == 0) { + Tcl_SetObjResult(interp, Tcl_NewListObj(0, NULL)); + return TCL_OK; + } - for (i = 0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); - !done; - Tcl_DictObjNext (&s, &key, NULL, &done), i++) { - if (done) break; - vals [i] = key; - } - Tcl_DictObjDone (&s); + vals = (Tcl_Obj**) ckalloc(n * sizeof(Tcl_Obj*)); - Tcl_SetObjResult (interp, Tcl_NewListObj (n, vals)); - ckfree ((char*) vals); + for (i=0, Tcl_DictObjFirst(interp, pkgDict, &s, &key, NULL, &done); + !done; Tcl_DictObjNext(&s, &key, NULL, &done), i++) { + vals[i] = key; + } - return TCL_OK; + Tcl_SetObjResult(interp, TclNewListObjDirect(n, vals)); + return TCL_OK; - default: - Tcl_Panic ("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen"); - break; + default: + Tcl_Panic("QueryConfigObjCmd: Unknown subcommand to 'pkgconfig'. This can't happen"); + break; } return TCL_ERROR; } diff --git a/generic/tclInt.decls b/generic/tclInt.decls index f04bc4d..8ddba3c 100644 --- a/generic/tclInt.decls +++ b/generic/tclInt.decls @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: tclInt.decls,v 1.63 2003/09/05 21:52:12 dgp Exp $ +# RCS: @(#) $Id: tclInt.decls,v 1.64 2003/11/01 01:20:34 dkf Exp $ library tcl @@ -725,6 +725,15 @@ declare 178 generic { declare 179 generic { Tcl_Obj *Tcl_GetStartupScript(CONST char **encodingNamePtr) } + +# Allocate lists without copying arrays +declare 180 generic { + Tcl_Obj *TclNewListObjDirect(int objc, Tcl_Obj *CONST objv[]) +} +declare 180 generic { + Tcl_Obj *TclDbNewListObjDirect(int objc, Tcl_Obj *CONST objv[], + CONST char *file, int line) +} ############################################################################## # Define the platform specific internal Tcl interface. These functions are diff --git a/generic/tclInt.h b/generic/tclInt.h index cbdbd10..0b36958 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.136 2003/10/14 15:44:52 dgp Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.137 2003/11/01 01:20:34 dkf Exp $ */ #ifndef _TCLINT @@ -2143,6 +2143,9 @@ EXTERN void TclDbInitNewObj _ANSI_ARGS_((Tcl_Obj *objPtr)); # define TclDecrRefCount(objPtr) \ Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__) +# define TclNewListObjDirect(objc, objv) \ + TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__) + #elif defined(PURIFY) /* diff --git a/generic/tclListObj.c b/generic/tclListObj.c index 8284a3e..020c725 100644 --- a/generic/tclListObj.c +++ b/generic/tclListObj.c @@ -11,7 +11,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclListObj.c,v 1.15 2003/10/30 22:18:07 dkf Exp $ + * RCS: @(#) $Id: tclListObj.c,v 1.16 2003/11/01 01:20:35 dkf Exp $ */ #include "tclInt.h" @@ -210,6 +210,120 @@ Tcl_DbNewListObj(objc, objv, file, line) /* *---------------------------------------------------------------------- * + * TclNewListObjDirect, TclDbNewListObjDirect -- + * + * Version of Tcl_NewListOb/Tcl_DbNewListObj that does not copy + * the array of Tcl_Objs. It still scans it though to update the + * reference counts. + * + * Results: + * A new list object is returned that is initialized from the object + * pointers in objv. If objc is less than or equal to zero, an empty + * object is returned (and "ownership" of the array of objects is + * not transferred.) The new object's string representation is left + * NULL. The resulting new list object has ref count 0. + * + * Side effects: + * The ref counts of the elements in objv are incremented since the + * resulting list now refers to them. + * + *---------------------------------------------------------------------- + */ + +#ifdef TCL_MEM_DEBUG +#undef TclNewListObjDirect +Tcl_Obj * +TclNewListObjDirect(objc, objv) + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ +{ + return TclDbNewListObjDirect(objc, objv, "unknown", 0); +} +#else /* !TCL_MEM_DEBUG */ +Tcl_Obj * +TclNewListObjDirect(objc, objv) + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ +{ + register Tcl_Obj *listPtr; + + TclNewObj(listPtr); + + if (objc > 0) { + register List *listRepPtr; + int i; + + Tcl_InvalidateStringRep(listPtr); + + for (i=0 ; imaxElemCount = objc; + listRepPtr->elemCount = objc; + listRepPtr->elements = objv; + + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr->typePtr = &tclListType; + } + return listPtr; +} +#endif /* TCL_MEM_DEBUG */ + +#ifdef TCL_MEM_DEBUG +Tcl_Obj * +TclDbNewListObjDirect(objc, objv, file, line) + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ + CONST char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + register Tcl_Obj *listPtr; + + TclDbNewObj(listPtr, file, line); + + if (objc > 0) { + register List *listRepPtr; + int i; + + Tcl_InvalidateStringRep(listPtr); + + for (i=0 ; imaxElemCount = objc; + listRepPtr->elemCount = objc; + listRepPtr->elements = objv; + + listPtr->internalRep.twoPtrValue.ptr1 = (VOID *) listRepPtr; + listPtr->internalRep.twoPtrValue.ptr2 = NULL; + listPtr->typePtr = &tclListType; + } + return listPtr; +} +#else /* !TCL_MEM_DEBUG */ +Tcl_Obj * +TclDbNewListObjDirect(objc, objv, file, line) + int objc; /* Count of objects referenced by objv. */ + Tcl_Obj *CONST objv[]; /* An array of pointers to Tcl objects. */ + CONST char *file; /* The name of the source file calling this + * procedure; used for debugging. */ + int line; /* Line number in the source file; used + * for debugging. */ +{ + return TclNewListObjDirect(objc, objv); +} +#endif /* TCL_MEM_DEBUG */ + +/* + *---------------------------------------------------------------------- + * * Tcl_SetListObj -- * * Modify an object to be a list containing each of the objc elements -- cgit v0.12