Tcl Source Code

Artifact Content
Login
Bounty program for improvements to Tcl and certain Tcl packages.

Artifact 3b68b7cd8131a42a46e81792f136a4ed448d707357ff5feb63e426d63458b70a:

Attachment "patch-a09031e288-quickfix.diff-c50-w" to ticket [a09031e288] added by leon 2018-12-10 20:21:09. (unpublished)
Index: generic/tclObj.c
==================================================================
--- generic/tclObj.c
+++ generic/tclObj.c
@@ -51,101 +51,101 @@
 
 char tclEmptyString = '\0';
 
 #if TCL_THREADS && defined(TCL_MEM_DEBUG)
 /*
  * Structure for tracking the source file and line number where a given
  * Tcl_Obj was allocated.  We also track the pointer to the Tcl_Obj itself,
  * for sanity checking purposes.
  */
 
 typedef struct {
     Tcl_Obj *objPtr;		/* The pointer to the allocated Tcl_Obj. */
     const char *file;		/* The name of the source file calling this
 				 * function; used for debugging. */
     int line;			/* Line number in the source file; used for
 				 * debugging. */
 } ObjData;
 #endif /* TCL_MEM_DEBUG && TCL_THREADS */
 
 /*
  * All static variables used in this file are collected into a single instance
  * of the following structure.  For multi-threaded implementations, there is
  * one instance of this structure for each thread.
  *
  * Notice that different structures with the same name appear in other files.
  * The structure defined below is used in this file only.
  */
 
 typedef struct {
     Tcl_HashTable *lineCLPtr;   /* This table remembers for each Tcl_Obj
                                  * generated by a call to the function
                                  * TclSubstTokens() from a literal text
                                  * where bs+nl sequences occured in it, if
                                  * any. I.e. this table keeps track of
                                  * invisible and stripped continuation lines.
                                  * Its keys are Tcl_Obj pointers, the values
                                  * are ContLineLoc pointers. See the file
                                  * tclCompile.h for the definition of this
                                  * structure, and for references to all
                                  * related places in the core. */
 #if TCL_THREADS && defined(TCL_MEM_DEBUG)
     Tcl_HashTable *objThreadMap;/* Thread local table that is used to check
                                  * that a Tcl_Obj was not allocated by some
                                  * other thread. */
 #endif /* TCL_MEM_DEBUG && TCL_THREADS */
 } ThreadSpecificData;
 
 static Tcl_ThreadDataKey dataKey;
 
 static void             TclThreadFinalizeContLines(ClientData clientData);
-static ThreadSpecificData *TclGetContLineTable(void);
+static Tcl_HashTable    *TclGetContLineTable(void);
 
 /*
  * Nested Tcl_Obj deletion management support
  *
  * All context references used in the object freeing code are pointers to this
  * structure; every thread will have its own structure instance. The purpose
  * of this structure is to allow deeply nested collections of Tcl_Objs to be
  * freed without taking a vast depth of C stack (which could cause all sorts
  * of breakage.)
  */
 
 typedef struct PendingObjData {
     int deletionCount;		/* Count of the number of invokations of
 				 * TclFreeObj() are on the stack (at least
 				 * conceptually; many are actually expanded
 				 * macros). */
     Tcl_Obj *deletionStack;	/* Stack of objects that have had TclFreeObj()
 				 * invoked upon them but which can't be
 				 * deleted yet because they are in a nested
 				 * invokation of TclFreeObj(). By postponing
 				 * this way, we limit the maximum overall C
 				 * stack depth when deleting a complex object.
 				 * The down-side is that we alter the overall
 				 * behaviour by altering the order in which
 				 * objects are deleted, and we change the
 				 * order in which the string rep and the
 				 * internal rep of an object are deleted. Note
 				 * that code which assumes the previous
 				 * behaviour in either of these respects is
 				 * unsafe anyway; it was never documented as
 				 * to exactly what would happen in these
 				 * cases, and the overall contract of a
 				 * user-level Tcl_DecrRefCount() is still
 				 * preserved (assuming that a particular T_DRC
 				 * would delete an object is not very
 				 * safe). */
 } PendingObjData;
 
 /*
  * These are separated out so that some semantic content is attached
  * to them.
  */
 #define ObjDeletionLock(contextPtr)	((contextPtr)->deletionCount++)
 #define ObjDeletionUnlock(contextPtr)	((contextPtr)->deletionCount--)
 #define ObjDeletePending(contextPtr)	((contextPtr)->deletionCount > 0)
 #define ObjOnStack(contextPtr)		((contextPtr)->deletionStack != NULL)
 #define PushObjToDelete(contextPtr,objPtr) \
     /* The string rep is already invalidated so we can use the bytes value \
      * for our pointer chain: push onto the head of the stack. */       \
     (objPtr)->bytes = (char *) ((contextPtr)->deletionStack);           \
@@ -435,166 +435,212 @@
 	    }
 	}
 
 	Tcl_DeleteHashTable(tablePtr);
 	Tcl_Free(tablePtr);
 	tsdPtr->objThreadMap = NULL;
     }
 #endif
 }
 
 /*
  *----------------------------------------------------------------------
  *
  * TclFinalizeObjects --
  *
  *	This function is called by Tcl_Finalize to clean up all registered
  *	Tcl_ObjType's and to reset the tclFreeObjList.
  *
  * Results:
  *	None.
  *
  * Side effects:
  *	None.
  *
  *----------------------------------------------------------------------
  */
 
 void
 TclFinalizeObjects(void)
 {
     Tcl_MutexLock(&tableMutex);
     if (typeTableInitialized) {
 	Tcl_DeleteHashTable(&typeTable);
 	typeTableInitialized = 0;
     }
     Tcl_MutexUnlock(&tableMutex);
 
     /*
      * All we do here is reset the head pointer of the linked list of free
      * Tcl_Obj's to NULL; the memory finalization will take care of releasing
      * memory for us.
      */
     Tcl_MutexLock(&tclObjMutex);
     tclFreeObjList = NULL;
     Tcl_MutexUnlock(&tclObjMutex);
 }
 
 /*
  *----------------------------------------------------------------------
  *
+ * Bookkeeping of line continuation (backslash+newline) sequences with
+ * the purpose of reporting correct line numbers in the result of
+ * [info frame level] introduces noticeable overhead in TclFreeObj().
+ * Therefore that functionality can be turned on or off via the
+ * environment variable TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS
+ * (setting it to 0 results in improved performance at the cost of
+ * worse debuggability of Tcl scripts, while any other value has an
+ * opposite effect). During compilation, defining a macro with the same
+ * name sets the default value for that setting.
+ *
+ *----------------------------------------------------------------------
+ */
+
+#ifndef TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS
+#define TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS 1
+#endif
+
+static int infoFrameMustReportAccurateLineNumbers(void)
+{
+    const char* v = getenv("TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS");
+    return v == NULL
+           ? TCL_INFO_FRAME_ENABLE_ACCURATE_LINE_NUMBERS
+           : strcmp(v, "0") != 0;
+}
+
+static int lineContinuationsMustBeTracked(void)
+{
+    static int x = -1;
+    if ( x == -1 )
+        x = (infoFrameMustReportAccurateLineNumbers() != 0);
+    return x;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclGetContLineTable --
  *
  *	This procedure is a helper which returns the thread-specific
  *	hash-table used to track continuation line information associated with
  *	Tcl_Obj*, and the objThreadMap, etc.
  *
  * Results:
  *	A reference to the thread-data.
  *
  * Side effects:
  *	May allocate memory for the thread-data.
  *
  * TIP #280
  *----------------------------------------------------------------------
  */
 
-static ThreadSpecificData *
+static Tcl_HashTable *
 TclGetContLineTable(void)
 {
+    ThreadSpecificData *tsdPtr;
+
+    if ( ! lineContinuationsMustBeTracked() )
+        return NULL;
+
     /*
      * Initialize the hashtable tracking invisible continuation lines.  For
      * the release we use a thread exit handler to ensure that this is done
      * before TSD blocks are made invalid. The TclFinalizeObjects() which
      * would be the natural place for this is invoked afterwards, meaning that
      * we try to operate on a data structure already gone.
      */
 
-    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+    tsdPtr = TCL_TSD_INIT(&dataKey);
 
     if (!tsdPtr->lineCLPtr) {
 	tsdPtr->lineCLPtr = Tcl_Alloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
 	Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
     }
-    return tsdPtr;
+    return tsdPtr->lineCLPtr;
 }
 
 /*
  *----------------------------------------------------------------------
  *
  * TclContinuationsEnter --
  *
  *	This procedure is a helper which saves the continuation line
  *	information associated with a Tcl_Obj*.
  *
  * Results:
  *	A reference to the newly created continuation line location table.
  *
  * Side effects:
  *	Allocates memory for the table of continuation line locations.
  *
  * TIP #280
  *----------------------------------------------------------------------
  */
 
 ContLineLoc *
 TclContinuationsEnter(
     Tcl_Obj *objPtr,
     int num,
     int *loc)
 {
     int newEntry;
-    ThreadSpecificData *tsdPtr = TclGetContLineTable();
-    Tcl_HashEntry *hPtr =
-	    Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
-    ContLineLoc *clLocPtr = Tcl_Alloc(sizeof(ContLineLoc) + num*sizeof(int));
+    Tcl_HashEntry *hPtr;
+    ContLineLoc *clLocPtr;
+
+    Tcl_HashTable *contLineTable = TclGetContLineTable();
+    if ( ! contLineTable )
+        return NULL;
+
+    hPtr = Tcl_CreateHashEntry(contLineTable, objPtr, &newEntry);
+    clLocPtr = Tcl_Alloc(sizeof(ContLineLoc) + num*sizeof(int));
 
     if (!newEntry) {
 	/*
 	 * We're entering ContLineLoc data for the same value more than one
 	 * time. Taking care not to leak the old entry.
 	 *
 	 * This can happen when literals in a proc body are shared. See for
 	 * example test info-30.19 where the action (code) for all branches of
 	 * the switch command is identical, mapping them all to the same
 	 * literal. An interesting result of this is that the number and
 	 * locations (offset) of invisible continuation lines in the literal
 	 * are the same for all occurences.
 	 *
 	 * Note that while reusing the existing entry is possible it requires
 	 * the same actions as for a new entry because we have to copy the
 	 * incoming num/loc data even so. Because we are called from
 	 * TclContinuationsEnterDerived for this case, which modified the
 	 * stored locations (Rebased to the proper relative offset). Just
 	 * returning the stored entry would rebase them a second time, or
 	 * more, hosing the data. It is easier to simply replace, as we are
 	 * doing.
 	 */
 
 	Tcl_Free(Tcl_GetHashValue(hPtr));
     }
 
     clLocPtr->num = num;
     memcpy(&clLocPtr->loc, loc, num*sizeof(int));
     clLocPtr->loc[num] = CLL_END;       /* Sentinel */
     Tcl_SetHashValue(hPtr, clLocPtr);
 
     return clLocPtr;
 }
 
 /*
  *----------------------------------------------------------------------
  *
  * TclContinuationsEnterDerived --
  *
  *	This procedure is a helper which computes the continuation line
  *	information associated with a Tcl_Obj* cut from the middle of a
  *	script.
  *
  * Results:
  *	None.
  *
  * Side effects:
  *	Allocates memory for the table of continuation line locations.
  *
  * TIP #280
@@ -653,183 +699,195 @@
     num = wordCLLast - clNext;
     if (num) {
 	int i;
 	ContLineLoc *clLocPtr = TclContinuationsEnter(objPtr, num, clNext);
 
 	/*
 	 * Re-base the locations.
 	 */
 
 	for (i=0 ; i<num ; i++) {
 	    clLocPtr->loc[i] -= start;
 
 	    /*
 	     * Continuation lines coming before the string and affecting us
 	     * should not happen, due to the proper maintenance of clNext
 	     * during compilation.
 	     */
 
 	    if (clLocPtr->loc[i] < 0) {
 		Tcl_Panic("Derived ICL data for object using offsets from before the script");
 	    }
 	}
     }
 }
 
 /*
  *----------------------------------------------------------------------
  *
  * TclContinuationsCopy --
  *
  *	This procedure is a helper which copies the continuation line
  *	information associated with a Tcl_Obj* to another Tcl_Obj*. It is
  *	assumed that both contain the same string/script. Use this when a
  *	script is duplicated because it was shared.
  *
  * Results:
  *	None.
  *
  * Side effects:
  *	Allocates memory for the table of continuation line locations.
  *
  * TIP #280
  *----------------------------------------------------------------------
  */
 
 void
 TclContinuationsCopy(
     Tcl_Obj *objPtr,
     Tcl_Obj *originObjPtr)
 {
-    ThreadSpecificData *tsdPtr = TclGetContLineTable();
-    Tcl_HashEntry *hPtr =
-            Tcl_FindHashEntry(tsdPtr->lineCLPtr, originObjPtr);
+    Tcl_HashEntry *hPtr;
+    Tcl_HashTable *contLineTable = TclGetContLineTable();
+    if ( ! contLineTable )
+        return;
+
+    hPtr = Tcl_FindHashEntry(contLineTable, originObjPtr);
 
     if (hPtr) {
 	ContLineLoc *clLocPtr = Tcl_GetHashValue(hPtr);
 
 	TclContinuationsEnter(objPtr, clLocPtr->num, clLocPtr->loc);
     }
 }
 
 /*
  *----------------------------------------------------------------------
  *
  * TclContinuationsGet --
  *
  *	This procedure is a helper which retrieves the continuation line
  *	information associated with a Tcl_Obj*, if it has any.
  *
  * Results:
  *	A reference to the continuation line location table, or NULL if the
  *	Tcl_Obj* has no such information associated with it.
  *
  * Side effects:
  *	None.
  *
  * TIP #280
  *----------------------------------------------------------------------
  */
 
 ContLineLoc *
 TclContinuationsGet(
     Tcl_Obj *objPtr)
 {
-    ThreadSpecificData *tsdPtr = TclGetContLineTable();
-    Tcl_HashEntry *hPtr =
-            Tcl_FindHashEntry(tsdPtr->lineCLPtr, objPtr);
+    Tcl_HashEntry *hPtr;
+    Tcl_HashTable *contLineTable = TclGetContLineTable();
+    if ( ! contLineTable )
+        return NULL;
+
+    hPtr = Tcl_FindHashEntry(contLineTable, objPtr);
 
     if (!hPtr) {
         return NULL;
     }
     return Tcl_GetHashValue(hPtr);
 }
 
 /*
  *----------------------------------------------------------------------
  *
  * TclThreadFinalizeContLines --
  *
  *	This procedure is a helper which releases all continuation line
  *	information currently known. It is run as a thread exit handler.
  *
  * Results:
  *	None.
  *
  * Side effects:
  *	Releases memory.
  *
  * TIP #280
  *----------------------------------------------------------------------
  */
 
 static void
 TclThreadFinalizeContLines(
     ClientData clientData)
 {
     /*
      * Release the hashtable tracking invisible continuation lines.
      */
 
-    ThreadSpecificData *tsdPtr = TclGetContLineTable();
     Tcl_HashEntry *hPtr;
     Tcl_HashSearch hSearch;
 
-    for (hPtr = Tcl_FirstHashEntry(tsdPtr->lineCLPtr, &hSearch);
+    Tcl_HashTable *contLineTable = TclGetContLineTable();
+    if ( ! contLineTable )
+        return;
+
+    for (hPtr = Tcl_FirstHashEntry(contLineTable, &hSearch);
 	    hPtr != NULL; hPtr = Tcl_NextHashEntry(&hSearch)) {
 	Tcl_Free(Tcl_GetHashValue(hPtr));
 	Tcl_DeleteHashEntry(hPtr);
     }
-    Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
-    Tcl_Free(tsdPtr->lineCLPtr);
+    Tcl_DeleteHashTable(contLineTable);
+    Tcl_Free(contLineTable);
+    {
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
     tsdPtr->lineCLPtr = NULL;
 }
+}
 
 /*
  *--------------------------------------------------------------
  *
  * Tcl_RegisterObjType --
  *
  *	This function is called to register a new Tcl object type in the table
  *	of all object types supported by Tcl.
  *
  * Results:
  *	None.
  *
  * Side effects:
  *	The type is registered in the Tcl type table. If there was already a
  *	type with the same name as in typePtr, it is replaced with the new
  *	type.
  *
  *--------------------------------------------------------------
  */
 
 void
 Tcl_RegisterObjType(
     const Tcl_ObjType *typePtr)	/* Information about object type; storage must
 				 * be statically allocated (must live
 				 * forever). */
 {
     int isNew;
 
     Tcl_MutexLock(&tableMutex);
     Tcl_SetHashValue(
 	    Tcl_CreateHashEntry(&typeTable, typePtr->name, &isNew), typePtr);
     Tcl_MutexUnlock(&tableMutex);
 }
 
 /*
  *----------------------------------------------------------------------
  *
  * Tcl_AppendAllObjTypes --
  *
  *	This function appends onto the argument object the name of each object
  *	type as a list element. This includes the builtin object types (e.g.
  *	int, list) as well as those added using Tcl_NewObj. These names can be
  *	used, for example, with Tcl_GetObjType to get pointers to the
  *	corresponding Tcl_ObjType structures.
  *
  * Results:
  *	The return value is normally TCL_OK; in this case the object
  *	referenced by objPtr has each type name appended to it. If an error
  *	occurs, TCL_ERROR is returned and the interpreter's result holds an
  *	error message.