Some locale operations need to be done in proper thread

This is a step in solving #20155

The POSIX 2008 locale API introduces per-thread locales.  But the
previous global locale system is retained, probably for backward
compatibility.

The POSIX 2008 interface causes memory to be malloc'd that needs to be
freed.  In order to do this, the caller must first stop using that
memory, by switching to another locale.  perl accomplishes this during
termination by switching to the global locale, which is always available
and doesn't need to be freed.

Perl has long assumed that all that was needed to switch threads was to
change out tTHX.  That's because that structure was intended to hold all
the information for a given thread.  But it turns out that this doesn't
work when some library independently holds information about the
thread's state.  And there are now some libraries that do that.

What was happening in this case was that perl thought that it was
sufficient to switch tTHX to change to a different thread in order to do
the freeing of memory, and then used the POSIX 2008 function to change
to the global locale so that the memory could be safely freed.  But the
POSIX 2008 function doesn't care about tTHX, and actually was typically
operating on a different thread, and so changed that thread to the global
locale instead of the intended thread.  Often that was the top-level
thread, thread 0.  That caused whatever thread it was to no longer be in
the expected locale, and to no longer be thread-safe with regards to
localess,

This commit causes locale_term(), which has always been called from the
actual terminating thread that POSIX 2008 knows about, to change to the
global thread and free the memory.

It also creates a new per-interpreter variable that effectively maps the
tTHX thread to the associated POSIX 2008 memory.  During
perl_destruct(), it frees the memory this variable points to, instead of
blindly assuming the memory to free is the current tTHX thread's.

This fixes the symptoms associtated with #20155, but doesn't solve the
whole problem.  In general, a library that has independent thread status
needs to be updated to the new thread when Perl changes threads using
tTHX.  Future commits will do this.

6 files changed, 52 insertions, 29 deletions

diff --git a/embedvar.h b/embedvar.h
index 8c6584722f..de295d2da2 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -87,6 +87,7 @@
 #define PL_cop_seqmax		(vTHX->Icop_seqmax)
 #define PL_ctype_name		(vTHX->Ictype_name)
 #define PL_cur_LC_ALL		(vTHX->Icur_LC_ALL)
+#define PL_cur_locale_obj	(vTHX->Icur_locale_obj)
 #define PL_curcop		(vTHX->Icurcop)
 #define PL_curcopdb		(vTHX->Icurcopdb)
 #define PL_curlocales		(vTHX->Icurlocales)
diff --git a/intrpvar.h b/intrpvar.h
index 75347aba77..c18170d7f7 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -738,6 +738,9 @@ PERLVAR(I, constpadix,	PADOFFSET)	/* lowest unused for constants */
 
 PERLVAR(I, padix_floor,	PADOFFSET)	/* how low may inner block reset padix */
 
+#if defined(USE_POSIX_2008_LOCALE) && defined(MULTIPLICITY)
+PERLVARI(I, cur_locale_obj, locale_t, NULL)
+#endif
 #ifdef USE_PL_CURLOCALES
 
 /* This is the most number of categories we've encountered so far on any
diff --git a/locale.c b/locale.c
index 94a64c8cdd..228b7c5159 100644
--- a/locale.c
+++ b/locale.c
@@ -1309,6 +1309,10 @@ S_emulate_setlocale_i(pTHX_
     DEBUG_Lv(PerlIO_printf(Perl_debug_log,
              "(%" LINE_Tf "): emulate_setlocale_i now using %p\n", line, new_obj));
 
+#ifdef MULTIPLICITY
+    PL_cur_locale_obj = new_obj;
+#endif
+
     /* We are done, except for updating our records (if the system doesn't keep
      * them) and in the case of locale "", we don't actually know what the
      * locale that got switched to is, as it came from the environment.  So
@@ -6723,31 +6727,28 @@ S_my_setlocale_debug_string_i(pTHX_
 void
 Perl_thread_locale_init(pTHX)
 {
-    /* Called from a thread on startup*/
 
 #ifdef USE_THREAD_SAFE_LOCALE
+#  ifdef USE_POSIX_2008_LOCALE
+
+    /* Called from a thread on startup.
+     *
+     * The operations here have to be done from within the calling thread, as
+     * they affect libc's knowledge of the thread; libc has no knowledge of
+     * aTHX */
 
      DEBUG_L(PerlIO_printf(Perl_debug_log,
                            "new thread, initial locale is %s;"
                            " calling setlocale(LC_ALL, \"C\")\n",
                            get_LC_ALL_display()));
-#  ifdef WIN32
 
-    /* On Windows, make sure new thread has per-thread locales enabled */
-    _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
-
-#  endif
-#  if defined(LC_ALL)
+    uselocale(PL_C_locale_obj);
 
-    /* This thread starts off in the C locale.  Use the full Perl_setlocale()
-     * to make sure no ill-advised shortcuts get taken on this new thread, */
-    Perl_setlocale(LC_ALL, "C");
+#  elif defined(WIN32)
 
-#  else
-
-    for (unsigned i = 0; i < NOMINAL_LC_ALL_INDEX; i++) {
-        Perl_setlocale(categories[i], "C");
-    }
+    /* On Windows, make sure new thread has per-thread locales enabled */
+    _configthreadlocale(_ENABLE_PER_THREAD_LOCALE);
+    void_setlocale_c(LC_ALL, "C");
 
 #  endif
 #endif
@@ -6757,20 +6758,34 @@ Perl_thread_locale_init(pTHX)
 void
 Perl_thread_locale_term(pTHX)
 {
-    /* Called from a thread as it gets ready to terminate */
+    /* Called from a thread as it gets ready to terminate.
+     *
+     * The operations here have to be done from within the calling thread, as
+     * they affect libc's knowledge of the thread; libc has no knowledge of
+     * aTHX */
 
 #ifdef USE_POSIX_2008_LOCALE
 
     /* C starts the new thread in the global C locale.  If we are thread-safe,
      * we want to not be in the global locale */
 
-    {   /* Free up */
-        locale_t cur_obj = uselocale(LC_GLOBAL_LOCALE);
-        if (cur_obj != LC_GLOBAL_LOCALE && cur_obj != PL_C_locale_obj) {
-            freelocale(cur_obj);
-        }
+    /* Free up */
+    locale_t actual_obj   = uselocale(LC_GLOBAL_LOCALE);
+    if (actual_obj != LC_GLOBAL_LOCALE && actual_obj != PL_C_locale_obj) {
+        freelocale(actual_obj);
     }
 
+    /* Prevent leaks even if something has gone wrong */
+    locale_t expected_obj = PL_cur_locale_obj;
+    if (UNLIKELY(   expected_obj != actual_obj
+                 && expected_obj != LC_GLOBAL_LOCALE
+                 && expected_obj != PL_C_locale_obj))
+    {
+        freelocale(expected_obj);
+    }
+
+    PL_cur_locale_obj = LC_GLOBAL_LOCALE;
+
 #endif
 
 }
diff --git a/makedef.pl b/makedef.pl
index b57bff933e..58918ca47b 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -386,6 +386,7 @@ unless ($define{'USE_ITHREADS'}) {
     ++$skip{$_} foreach qw(
                     PL_keyword_plugin_mutex
 		    PL_check_mutex
+                    PL_cur_locale_obj
 		    PL_op_mutex
 		    PL_regex_pad
 		    PL_regex_padav
diff --git a/perl.c b/perl.c
index 0a3ec39811..417381683c 100644
--- a/perl.c
+++ b/perl.c
@@ -1129,15 +1129,17 @@ perl_destruct(pTHXx)
     {
         /* This also makes sure we aren't using a locale object that gets freed
          * below */
-        const locale_t old_locale = uselocale(LC_GLOBAL_LOCALE);
-        if (   old_locale != LC_GLOBAL_LOCALE
-#  ifdef USE_POSIX_2008_LOCALE
-            && old_locale != PL_C_locale_obj
-#  endif
+        if (   PL_cur_locale_obj != NULL
+            && PL_cur_locale_obj != LC_GLOBAL_LOCALE
+            && PL_cur_locale_obj != PL_C_locale_obj
         ) {
-            DEBUG_Lv(PerlIO_printf(Perl_debug_log,
-                     "%s:%d: Freeing %p\n", __FILE__, __LINE__, old_locale));
-            freelocale(old_locale);
+            locale_t cur_locale = uselocale((locale_t) 0);
+            if (cur_locale == PL_cur_locale_obj) {
+                uselocale(LC_GLOBAL_LOCALE);
+            }
+
+            freelocale(PL_cur_locale_obj);
+            PL_cur_locale_obj = NULL;
         }
     }
 
diff --git a/sv.c b/sv.c
index bc5f95143b..99b71c65ab 100644
--- a/sv.c
+++ b/sv.c
@@ -15939,6 +15939,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 #endif /* !USE_LOCALE_NUMERIC */
 #if defined(USE_POSIX_2008_LOCALE)
     PL_scratch_locale_obj = NULL;
+    PL_cur_locale_obj = PL_C_locale_obj;
 #endif
 
 #ifdef HAS_MBRLEN