Merge 8.7

generic/tclBasic.c

@@ -64,6 +64,41 @@
 #endif /* !TCL_FPCLASSIFY_MODE */
 
 
+/*
+ * Bug 7371b6270b: to check C call stack depth, prefer an approach which is
+ * compatible with AddressSanitizer (ASan) use-after-return detection.
+ */
+
+#if defined(HAVE_INTRIN_H)
+#include <intrin.h> /* for _AddressOfReturnAddress() */
+#endif
+
+/*
+ * As suggested by
+ * https://clang.llvm.org/docs/LanguageExtensions.html#has-builtin
+ */
+#ifndef __has_builtin
+#define __has_builtin(x) 0 /* for non-clang compilers */
+#endif
+
+void *
+TclGetCStackPtr(void)
+{
+#if defined(HAVE_INTRIN_H)
+  return _AddressOfReturnAddress();
+#elif __GNUC__ || __has_builtin(__builtin_frame_address)
+  return __builtin_frame_address(0);
+#else
+  ptrdiff_t unused = 0;
+  /*
+   * LLVM recommends using volatile:
+   * https://github.com/llvm/llvm-project/blob/llvmorg-10.0.0-rc1/clang/lib/Basic/Stack.cpp#L31
+   */
+  ptrdiff_t *volatile stackLevel = &unused;
+  return (void *)stackLevel;
+#endif
+}
+
 #define INTERP_STACK_INITIAL_SIZE 2000
 #define CORO_STACK_INITIAL_SIZE    200
 
@@ -9211,6 +9246,7 @@ TclNRCoroutineActivateCallback(
     TCL_UNUSED(int) /*result*/)
 {
     CoroutineData *corPtr = (CoroutineData *)data[0];
+    void *stackLevel = TclGetCStackPtr();
 
     if (!corPtr->stackLevel) {
         /*
@@ -9227,7 +9263,7 @@ TclNRCoroutineActivateCallback(
          * the interp's environment to make it suitable to run this coroutine.
          */
 
-        corPtr->stackLevel = &corPtr;
+        corPtr->stackLevel = stackLevel;
         Tcl_Size numLevels = corPtr->auxNumLevels;
         corPtr->auxNumLevels = iPtr->numLevels;
 
@@ -9241,7 +9277,7 @@ TclNRCoroutineActivateCallback(
          * Coroutine is active: yield
          */
 
-        if (corPtr->stackLevel != &corPtr) {
+        if (corPtr->stackLevel != stackLevel) {
 	    NRE_callback *runPtr;
 
 	    iPtr->execEnvPtr = corPtr->callerEEPtr;

generic/tclIOUtil.c

@@ -4316,7 +4316,7 @@ Tcl_FSDeleteFile(
 {
     const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
     int err;
-    
+
     if (fsPtr == NULL) {
 	err = ENOENT;
     } else {

generic/tclInt.decls

@@ -560,6 +560,10 @@ declare 221 {
 declare 222 {
     void TclListObjValidate(Tcl_Interp *interp, Tcl_Obj *listObj)
 }
+# Bug 7371b6270b
+declare 223 {
+    void *TclGetCStackPtr(void)
+}
 declare 224 {
     TclPlatformType *TclGetPlatform(void)
 }

generic/tclIntDecls.h

@@ -469,7 +469,8 @@ EXTERN Tcl_Obj *	TclListTestObj(size_t length, size_t leadingSpace,
 /* 222 */
 EXTERN void		TclListObjValidate(Tcl_Interp *interp,
 				Tcl_Obj *listObj);
-/* Slot 223 is reserved */
+/* 223 */
+EXTERN void *		TclGetCStackPtr(void);
 /* 224 */
 EXTERN TclPlatformType * TclGetPlatform(void);
 /* 225 */
@@ -810,7 +811,7 @@ typedef struct TclIntStubs {
     void (*reserved220)(void);
     Tcl_Obj * (*tclListTestObj) (size_t length, size_t leadingSpace, size_t endSpace); /* 221 */
     void (*tclListObjValidate) (Tcl_Interp *interp, Tcl_Obj *listObj); /* 222 */
-    void (*reserved223)(void);
+    void * (*tclGetCStackPtr) (void); /* 223 */
     TclPlatformType * (*tclGetPlatform) (void); /* 224 */
     Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, Tcl_Size keyc, Tcl_Obj *const keyv[], int flags); /* 225 */
     int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */
@@ -1196,7 +1197,8 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclListTestObj) /* 221 */
 #define TclListObjValidate \
 	(tclIntStubsPtr->tclListObjValidate) /* 222 */
-/* Slot 223 is reserved */
+#define TclGetCStackPtr \
+	(tclIntStubsPtr->tclGetCStackPtr) /* 223 */
 #define TclGetPlatform \
 	(tclIntStubsPtr->tclGetPlatform) /* 224 */
 #define TclTraceDictPath \

generic/tclStubInit.c

@@ -628,7 +628,7 @@ static const TclIntStubs tclIntStubs = {
     0, /* 220 */
     TclListTestObj, /* 221 */
     TclListObjValidate, /* 222 */
-    0, /* 223 */
+    TclGetCStackPtr, /* 223 */
     TclGetPlatform, /* 224 */
     TclTraceDictPath, /* 225 */
     TclObjBeingDeleted, /* 226 */

generic/tclTest.c

@@ -7917,22 +7917,22 @@ NREUnwind_callback(
     Tcl_Interp *interp,
     TCL_UNUSED(int) /*result*/)
 {
-    int none;
+    void *cStackPtr = TclGetCStackPtr();
 
     if (data[0] == INT2PTR(-1)) {
-        Tcl_NRAddCallback(interp, NREUnwind_callback, &none, INT2PTR(-1),
+        Tcl_NRAddCallback(interp, NREUnwind_callback, cStackPtr, INT2PTR(-1),
                 INT2PTR(-1), NULL);
     } else if (data[1] == INT2PTR(-1)) {
-        Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], &none,
+        Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], cStackPtr,
                 INT2PTR(-1), NULL);
     } else if (data[2] == INT2PTR(-1)) {
         Tcl_NRAddCallback(interp, NREUnwind_callback, data[0], data[1],
-                &none, NULL);
+                cStackPtr, NULL);
     } else {
         Tcl_Obj *idata[3];
         idata[0] = Tcl_NewWideIntObj(((char *) data[1] - (char *) data[0]));
         idata[1] = Tcl_NewWideIntObj(((char *) data[2] - (char *) data[0]));
-        idata[2] = Tcl_NewWideIntObj(((char *) &none   - (char *) data[0]));
+        idata[2] = Tcl_NewWideIntObj(((char *) cStackPtr - (char *) data[0]));
         Tcl_SetObjResult(interp, Tcl_NewListObj(3, idata));
     }
     return TCL_OK;
@@ -7971,10 +7971,10 @@ TestNRELevels(
     NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
 
     if (refDepth == NULL) {
-	refDepth = &depth;
+	refDepth = (ptrdiff_t *)TclGetCStackPtr();
     }
 
-    depth = (refDepth - &depth);
+    depth = (refDepth - (ptrdiff_t *)TclGetCStackPtr());
 
     levels[0] = Tcl_NewWideIntObj(depth);
     levels[1] = Tcl_NewWideIntObj(iPtr->numLevels);

generic/tclZipfs.c

@@ -737,11 +737,11 @@ CountSlashes(
  *------------------------------------------------------------------------
  */
 static int IsCryptHeaderValid(
-	ZipEntry *z, 
+	ZipEntry *z,
 	unsigned char cryptHeader[12]
 	)
 {
-    /* 
+    /*
      * There are multiple possibilities. The last one or two bytes of the
      * encryption header should match the last one or two bytes of the
      * CRC of the file. Or the last byte of the encryption header should
@@ -1664,7 +1664,7 @@ ZipFSOpenArchive(
 	    goto error;
 	}
     }
-    /* 
+    /*
      * Close the Tcl channel. If the file was mapped, the mapping is
      * unaffected. It is important to close the channel otherwise there is a
      * potential chicken and egg issue at finalization time as the channels
@@ -2199,7 +2199,7 @@ ListMountPoints(
  *
  *    Releases all resources associated with a mounted archive. There
  *    must not be any open files in the archive.
- * 
+ *
  *    Caller MUST be holding WriteLock() before calling this function.
  *
  * Results:
@@ -4878,7 +4878,7 @@ InitWritableChannel(
 	    goto error_cleanup;
 	}
     }
-    
+
     if (mode & O_TRUNC) {
 	/*
 	 * Truncate; nothing there.
@@ -5260,7 +5260,7 @@ ZipEntryAccess(
 	} else {
 	    /*
 	     * Even if entry does not exist, could be intermediate dir
-	     * containing a mount point 
+	     * containing a mount point
 	     */
 	    access = ContainsMountPoint(path, -1) ? 0 : -1;
 	}
@@ -5568,9 +5568,9 @@ ZipFSMatchInDirectoryProc(
 		AppendWithPrefix(result, prefixBuf, z->name + strip, -1);
 	    }
 	}
-    } 
+    }
     if (dirOnly) {
-	/* 
+	/*
 	 * Not found in hash. May be a path that is the ancestor of a mount.
 	 * e.g. glob //zipfs:/a/? with mount at //zipfs:/a/b/c. Also have
 	 * to be careful about duplicates, such as when another mount is