diff options
Diffstat (limited to 'tcl/generic/tclBinary.c')
| -rw-r--r-- | tcl/generic/tclBinary.c | 229 |
1 files changed, 195 insertions, 34 deletions
diff --git a/tcl/generic/tclBinary.c b/tcl/generic/tclBinary.c index 199109637a5..6065d018d5a 100644 --- a/tcl/generic/tclBinary.c +++ b/tcl/generic/tclBinary.c @@ -13,9 +13,9 @@ * RCS: @(#) $Id$ */ -#include <math.h> #include "tclInt.h" #include "tclPort.h" +#include <math.h> /* * The following constants are used by GetFormatSpec to indicate various @@ -26,6 +26,26 @@ #define BINARY_NOCOUNT -2 /* No count was specified in format. */ /* + * The following defines the maximum number of different (integer) + * numbers placed in the object cache by 'binary scan' before it bails + * out and switches back to Plan A (creating a new object for each + * value.) Theoretically, it would be possible to keep the cache + * about for the values that are already in it, but that makes the + * code slower in practise when overflow happens, and makes little + * odds the rest of the time (as measured on my machine.) It is also + * slower (on the sample I tried at least) to grow the cache to hold + * all items we might want to put in it; presumably the extra cost of + * managing the memory for the enlarged table outweighs the benefit + * from allocating fewer objects. This is probably because as the + * number of objects increases, the likelihood of reuse of any + * particular one drops, and there is very little gain from larger + * maximum cache sizes (the value below is chosen to allow caching to + * work in full with conversion of bytes.) - DKF + */ + +#define BINARY_SCAN_MAX_CACHE 260 + +/* * Prototypes for local procedures defined in this file: */ @@ -36,7 +56,8 @@ static int FormatNumber _ANSI_ARGS_((Tcl_Interp *interp, int type, static void FreeByteArrayInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetFormatSpec _ANSI_ARGS_((char **formatPtr, char *cmdPtr, int *countPtr)); -static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type)); +static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, + int type, Tcl_HashTable **numberCachePtr)); static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr)); @@ -125,7 +146,7 @@ typedef struct ByteArray { Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) - unsigned char *bytes; /* The array of bytes used to initialize + CONST unsigned char *bytes; /* The array of bytes used to initialize * the new object. */ int length; /* Length of the array of bytes, which must * be >= 0. */ @@ -137,7 +158,7 @@ Tcl_NewByteArrayObj(bytes, length) Tcl_Obj * Tcl_NewByteArrayObj(bytes, length) - unsigned char *bytes; /* The array of bytes used to initialize + CONST unsigned char *bytes; /* The array of bytes used to initialize * the new object. */ int length; /* Length of the array of bytes, which must * be >= 0. */ @@ -159,8 +180,8 @@ Tcl_NewByteArrayObj(bytes, length) * TCL_MEM_DEBUG is defined. It is the same as the Tcl_NewByteArrayObj * above except that it calls Tcl_DbCkalloc directly with the file name * and line number from its caller. This simplifies debugging since then - * the checkmem command will report the correct file name and line number - * when reporting objects that haven't been freed. + * the [memory active] command will report the correct file name and line + * number when reporting objects that haven't been freed. * * When TCL_MEM_DEBUG is not defined, this procedure just returns the * result of calling Tcl_NewByteArrayObj. @@ -180,11 +201,11 @@ Tcl_NewByteArrayObj(bytes, length) Tcl_Obj * Tcl_DbNewByteArrayObj(bytes, length, file, line) - unsigned char *bytes; /* The array of bytes used to initialize + CONST unsigned char *bytes; /* The array of bytes used to initialize * the new object. */ int length; /* Length of the array of bytes, which must * be >= 0. */ - char *file; /* The name of the source file calling this + 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. */ @@ -200,11 +221,11 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line) Tcl_Obj * Tcl_DbNewByteArrayObj(bytes, length, file, line) - unsigned char *bytes; /* The array of bytes used to initialize + CONST unsigned char *bytes; /* The array of bytes used to initialize * the new object. */ int length; /* Length of the array of bytes, which must * be >= 0. */ - char *file; /* The name of the source file calling this + 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. */ @@ -234,7 +255,7 @@ Tcl_DbNewByteArrayObj(bytes, length, file, line) void Tcl_SetByteArrayObj(objPtr, bytes, length) Tcl_Obj *objPtr; /* Object to initialize as a ByteArray. */ - unsigned char *bytes; /* The array of bytes to use as the new + CONST unsigned char *bytes; /* The array of bytes to use as the new * value. */ int length; /* Length of the array of bytes, which must * be >= 0. */ @@ -561,7 +582,7 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) * cursor has visited.*/ char *errorString, *errorValue, *str; int offset, size, length, index; - static char *options[] = { + static CONST char *options[] = { "format", "scan", NULL }; enum options { @@ -644,6 +665,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) size = 4; goto doNumbers; } + case 'w': + case 'W': { + size = 8; + goto doNumbers; + } case 'f': { size = sizeof(float); goto doNumbers; @@ -924,6 +950,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case 'S': case 'i': case 'I': + case 'w': + case 'W': case 'd': case 'f': { int listc, i; @@ -996,12 +1024,16 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) case BINARY_SCAN: { int i; Tcl_Obj *valuePtr, *elementPtr; + Tcl_HashTable numberCacheHash; + Tcl_HashTable *numberCachePtr; if (objc < 4) { Tcl_WrongNumArgs(interp, 2, objv, "value formatString ?varName varName ...?"); return TCL_ERROR; } + numberCachePtr = &numberCacheHash; + Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); buffer = Tcl_GetByteArrayFromObj(objv[2], &length); format = Tcl_GetString(objv[3]); cursor = buffer; @@ -1018,6 +1050,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) unsigned char *src; if (arg >= objc) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badIndex; } if (count == BINARY_ALL) { @@ -1051,6 +1086,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } @@ -1063,6 +1101,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) char *dest; if (arg >= objc) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badIndex; } if (count == BINARY_ALL) { @@ -1104,6 +1145,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } @@ -1118,6 +1162,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) static char hexdigit[] = "0123456789abcdef"; if (arg >= objc) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badIndex; } if (count == BINARY_ALL) { @@ -1159,6 +1206,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } @@ -1179,6 +1229,11 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) size = 4; goto scanNumber; } + case 'w': + case 'W': { + size = 8; + goto scanNumber; + } case 'f': { size = sizeof(float); goto scanNumber; @@ -1191,13 +1246,17 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) scanNumber: if (arg >= objc) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badIndex; } if (count == BINARY_NOCOUNT) { if ((length - offset) < size) { goto done; } - valuePtr = ScanNumber(buffer+offset, cmd); + valuePtr = ScanNumber(buffer+offset, cmd, + &numberCachePtr); offset += size; } else { if (count == BINARY_ALL) { @@ -1209,7 +1268,8 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) valuePtr = Tcl_NewObj(); src = buffer+offset; for (i = 0; i < count; i++) { - elementPtr = ScanNumber(src, cmd); + elementPtr = ScanNumber(src, cmd, + &numberCachePtr); src += size; Tcl_ListObjAppendElement(NULL, valuePtr, elementPtr); @@ -1221,6 +1281,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) NULL, valuePtr, TCL_LEAVE_ERR_MSG); arg++; if (resultPtr == NULL) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } Tcl_DecrRefCount(valuePtr); /* unneeded */ return TCL_ERROR; } @@ -1251,6 +1314,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) } case '@': { if (count == BINARY_NOCOUNT) { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } goto badCount; } if ((count == BINARY_ALL) || (count > length)) { @@ -1261,6 +1327,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) break; } default: { + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } errorString = str; goto badfield; } @@ -1274,6 +1343,9 @@ Tcl_BinaryObjCmd(dummy, interp, objc, objv) done: Tcl_ResetResult(interp); Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4); + if (numberCachePtr != NULL) { + Tcl_DeleteHashTable(numberCachePtr); + } break; } } @@ -1393,10 +1465,13 @@ FormatNumber(interp, type, src, cursorPtr) Tcl_Obj *src; /* Number to format. */ unsigned char **cursorPtr; /* Pointer to index into destination buffer. */ { - int value; + long value; double dvalue; + Tcl_WideInt wvalue; - if ((type == 'd') || (type == 'f')) { + switch (type) { + case 'd': + case 'f': /* * For floating point types, we need to copy the data using * memcpy to avoid alignment issues. @@ -1425,8 +1500,39 @@ FormatNumber(interp, type, src, cursorPtr) memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float)); *cursorPtr += sizeof(float); } - } else { - if (Tcl_GetIntFromObj(interp, src, &value) != TCL_OK) { + return TCL_OK; + + /* + * Next cases separate from other integer cases because we + * need a different API to get a wide. + */ + case 'w': + case 'W': + if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) { + return TCL_ERROR; + } + if (type == 'w') { + *(*cursorPtr)++ = (unsigned char) wvalue; + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); + } else { + *(*cursorPtr)++ = (unsigned char) (wvalue >> 56); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 48); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 40); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 32); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 24); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 16); + *(*cursorPtr)++ = (unsigned char) (wvalue >> 8); + *(*cursorPtr)++ = (unsigned char) wvalue; + } + return TCL_OK; + default: + if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) { return TCL_ERROR; } if (type == 'c') { @@ -1448,8 +1554,8 @@ FormatNumber(interp, type, src, cursorPtr) *(*cursorPtr)++ = (unsigned char) (value >> 8); *(*cursorPtr)++ = (unsigned char) value; } + return TCL_OK; } - return TCL_OK; } /* @@ -1465,17 +1571,24 @@ FormatNumber(interp, type, src, cursorPtr) * This object has a ref count of zero. * * Side effects: - * None. + * Might reuse an object in the number cache, place a new object + * in the cache, or delete the cache and set the reference to + * it (itself passed in by reference) to NULL. * *---------------------------------------------------------------------- */ static Tcl_Obj * -ScanNumber(buffer, type) +ScanNumber(buffer, type, numberCachePtrPtr) unsigned char *buffer; /* Buffer to scan number from. */ int type; /* Format character from "binary scan" */ + Tcl_HashTable **numberCachePtrPtr; + /* Place to look for cache of scanned + * value objects, or NULL if too many + * different numbers have been scanned. */ { long value; + Tcl_WideInt wvalue; /* * We cannot rely on the compiler to properly sign extend integer values @@ -1486,7 +1599,7 @@ ScanNumber(buffer, type) */ switch (type) { - case 'c': { + case 'c': /* * Characters need special handling. We want to produce a * signed result, but on some platforms (such as AIX) chars @@ -1498,28 +1611,26 @@ ScanNumber(buffer, type) if (value & 0x80) { value |= -0x100; } - return Tcl_NewLongObj((long)value); - } - case 's': { + goto returnNumericObject; + + case 's': value = (long) (buffer[0] + (buffer[1] << 8)); goto shortValue; - } - case 'S': { + case 'S': value = (long) (buffer[1] + (buffer[0] << 8)); shortValue: if (value & 0x8000) { value |= -0x10000; } - return Tcl_NewLongObj(value); - } - case 'i': { + goto returnNumericObject; + + case 'i': value = (long) (buffer[0] + (buffer[1] << 8) + (buffer[2] << 16) + (buffer[3] << 24)); goto intValue; - } - case 'I': { + case 'I': value = (long) (buffer[3] + (buffer[2] << 8) + (buffer[1] << 16) @@ -1534,8 +1645,58 @@ ScanNumber(buffer, type) value -= (((unsigned int)1)<<31); value -= (((unsigned int)1)<<31); } - return Tcl_NewLongObj(value); - } + returnNumericObject: + if (*numberCachePtrPtr == NULL) { + return Tcl_NewLongObj(value); + } else { + register Tcl_HashTable *tablePtr = *numberCachePtrPtr; + register Tcl_HashEntry *hPtr; + int isNew; + + hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew); + if (!isNew) { + return (Tcl_Obj *) Tcl_GetHashValue(hPtr); + } + if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) { + /* + * We've overflowed the cache! Someone's parsing + * a LOT of varied binary data in a single call! + * Bail out by switching back to the old behaviour + * for the rest of the scan. + * + * Note that anyone just using the 'c' conversion + * (for bytes) cannot trigger this. + */ + Tcl_DeleteHashTable(tablePtr); + *numberCachePtrPtr = NULL; + return Tcl_NewLongObj(value); + } else { + register Tcl_Obj *objPtr = Tcl_NewLongObj(value); + /* Don't need to fiddle with refcount... */ + Tcl_SetHashValue(hPtr, (ClientData) objPtr); + return objPtr; + } + } + case 'w': + value = (long) (buffer[4] + | (buffer[5] << 8) + | (buffer[6] << 16) + | (buffer[7] << 24)); + wvalue = ((Tcl_WideInt) value) << 32 | (buffer[0] + | (buffer[1] << 8) + | (buffer[2] << 16) + | (buffer[3] << 24)); + return Tcl_NewWideIntObj(wvalue); + case 'W': + value = (long) (buffer[3] + | (buffer[2] << 8) + | (buffer[1] << 16) + | (buffer[0] << 24)); + wvalue = ((Tcl_WideInt) value) << 32 | (buffer[7] + | (buffer[6] << 8) + | (buffer[5] << 16) + | (buffer[4] << 24)); + return Tcl_NewWideIntObj(wvalue); case 'f': { float fvalue; memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float)); |