Don't end up in global locale upon thread destruction

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

Prior to this commit, there was a bug in which, when a thread
terminates, the master thread was switched into the global locale.  That
meant that that thread was no longer thread-safe with regards to
locales.

This bug stems from the fact that perl assumes that all you need to do
to switch between threads (or embedded interpreters) is to change out
aTHX.  Indeed much effort was expended in crafting perl to make this the
case.  But it breaks down in the case of some alien library that keeps
per-thread information.  That library needs to be informed of the
switch.  In this case it is libc keeping per-thread locale information.
We change the thread context, but the library still retains the old
thread's locale.

One cannot be using a given locale object and successfully free it.
Therefore the code switches to the global locale (which isn't
deletable) before freeing.  There was no apparent need to do more
switching, as the thread is in the process of dying.  What I was unaware
of is that it is the parent thread pretending to be the dying one for the
purposes of destruction.  So switching to the global locale affected the
parent, leaving it there.

The parent thread called the locale.c thread locale termination
function, and then called the perl.c perl_destruct() on the thread.  This
commit moves all the code for thread destruction from perl.c into the
locale.c code, and calls it.  Thus the thread initiation and termination
is moved into locale.c

The thread termination is also called from thread.c.  This cleans up a
dying thread.  The perl.c call is needed for thread0 and
non-multiplicity builds.  A check is done to prevent duplicate work.

This commit adds a new per-interpreter variable which maps aTHX to its
locale.  This is used to get the terminating thread's locale instead of
the master.  And the master locale is switched back to at the end.

This commit is incomplete.  Something similar needs to be done for
Windows where the libc knows the per-thread locale.

I'm unsure of if this is the full correct approach.  It only works for
thread termination.  Perhaps a better solution would be to change the
locale every time aTHX is changed.  PERL_SET_INTERP, PERL_SET_CONTEXT,
and PERL_SET_THX all seem to do the aTHX change, and I can't figure out
when you would prefer one over the other.  But maybe one of them should
then arrange also to change the locale when aTHX is changed.

Perhaps you can think of other libraries and functions that have a
similar problem that also would need something like this.

This commit causes Perl#20155 to go away.  The triggering failure is merely
a symptom of the deeper problem.  A proper test will need to be done in
XS.

dist/threads/threads.xs

@@ -256,6 +256,7 @@ S_ithread_clear(pTHX_ ithread *thread)
             thread->err = Nullsv;
         }
 
+        Perl_thread_locale_term(interp, true /* Called from threads */);
         perl_destruct(interp);
         perl_free(interp);
         thread->interp = NULL;
@@ -667,8 +668,6 @@ S_ithread_run(void * arg)
     MUTEX_UNLOCK(&thread->mutex);
     MUTEX_UNLOCK(&MY_POOL.create_destruct_mutex);
 
-    thread_locale_term();
-
     /* Exit application if required */
     if (exit_app) {
         (void)S_jmpenv_run(aTHX_ 2, thread, NULL, &exit_app, &exit_code);

embed.fnc

@@ -1660,8 +1660,8 @@ Xp	|void	|set_numeric_standard
 Cp	|bool	|_is_in_locale_category|const bool compiling|const int category
 ApdT	|void	|switch_to_global_locale
 ApdT	|bool	|sync_locale
-CpT	|void	|thread_locale_init
-CpT	|void	|thread_locale_term
+Cp	|void	|thread_locale_init
+Cp	|void	|thread_locale_term|const bool caller_is_thread_termination
 ApdO	|void	|require_pv	|NN const char* pv
 Apd	|void	|packlist	|NN SV *cat|NN const char *pat|NN const char *patend|NN SV **beglist|NN SV **endlist
 #if defined(PERL_USES_PL_PIDSTATUS) && defined(PERL_IN_UTIL_C)

embed.h

@@ -696,8 +696,8 @@
 #define sync_locale		Perl_sync_locale
 #define taint_env()		Perl_taint_env(aTHX)
 #define taint_proper(a,b)	Perl_taint_proper(aTHX_ a,b)
-#define thread_locale_init	Perl_thread_locale_init
-#define thread_locale_term	Perl_thread_locale_term
+#define thread_locale_init()	Perl_thread_locale_init(aTHX)
+#define thread_locale_term(a)	Perl_thread_locale_term(aTHX_ a)
 #define to_uni_lower(a,b,c)	Perl_to_uni_lower(aTHX_ a,b,c)
 #define to_uni_title(a,b,c)	Perl_to_uni_title(aTHX_ a,b,c)
 #define to_uni_upper(a,b,c)	Perl_to_uni_upper(aTHX_ a,b,c)

intrpvar.h

@@ -739,14 +739,17 @@ 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(USE_THREAD_SAFE_LOCALE)         \
- && ! defined(HAS_QUERYLOCALE)
+#if defined(USE_POSIX_2008_LOCALE)
+#  if defined(MULTIPLICITY)
+PERLVARI(I, thread_locale, locale_t, 0)
+#  endif
+#  if defined(USE_THREAD_SAFE_LOCALE) && ! defined(HAS_QUERYLOCALE)
 
 /* This is the most number of categories we've encountered so far on any
  * platform */
 PERLVARA(I, curlocales, 12, const char *)
 
+#  endif
 #endif
 #ifdef USE_LOCALE_COLLATE
 

locale.c

@@ -1301,6 +1301,7 @@ S_emulate_setlocale_i(pTHX_
 
 #  endif
 
+    PL_thread_locale = new_obj;
     return new_locale;
 }
 
@@ -6930,15 +6931,12 @@ S_setlocale_debug_string_i(const unsigned cat_index,
 #endif
 
 void
-Perl_thread_locale_init()
+Perl_thread_locale_init(pTHX)
 {
     /* Called from a thread on startup*/
 
 #ifdef USE_THREAD_SAFE_LOCALE
 
-    dTHX_DEBUGGING;
-
-
      DEBUG_L(PerlIO_printf(Perl_debug_log,
             "new thread, initial locale is %s; calling setlocale\n",
             setlocale(LC_ALL, NULL)));
@@ -6959,24 +6957,97 @@ Perl_thread_locale_init()
 }
 
 void
-Perl_thread_locale_term()
+Perl_thread_locale_term(pTHX_ const bool caller_is_thread_termination)
 {
     /* Called from a thread as it gets ready to terminate */
 
 #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 */
+    /* Setting this to NULL, indicates the work has already been done */
+    if (! PL_thread_locale) {
+        return;
+    }
 
-    {   /* 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);
-        }
+    /* When called from thread termination, it is thread0 pretending to be the
+     * dying thread.  So save its locale, and switch into the proper one for
+     * the dying thread */
+    locale_t caller_locale = NULL;
+    if (caller_is_thread_termination) {
+        caller_locale = uselocale(PL_thread_locale);
+        PL_thread_locale = NULL;
+    }
+
+    /* Switching to the global locale 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 != caller_locale && old_locale != LC_GLOBAL_LOCALE) {
+        freelocale(old_locale);
+    }
+
+#  ifdef USE_PL_CURLOCALES
+
+    for (unsigned i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
+        Safefree(PL_curlocales[i]);
+        PL_curlocales[i] = NULL;
+    }
+
+#  endif
+
+    if (PL_scratch_locale_obj && PL_scratch_locale_obj != old_locale) {
+        freelocale(PL_scratch_locale_obj);
+    }
+    PL_scratch_locale_obj = NULL;
+
+#  ifdef USE_LOCALE_NUMERIC
+
+    if (PL_underlying_numeric_obj && PL_underlying_numeric_obj != old_locale) {
+        DEBUG_Lv(PerlIO_printf(Perl_debug_log,
+                    "Freeing %p\n", PL_underlying_numeric_obj));
+        freelocale(PL_underlying_numeric_obj);
+    }
+    PL_underlying_numeric_obj = (locale_t) NULL;
+
+#  endif
+
+    /* Switch back to the thread0 locale as it continues on. */
+    if (caller_is_thread_termination && caller_locale != old_locale) {
+        uselocale(caller_locale);
     }
 
 #endif
 
+    /* free locale stuff */
+
+    if (PL_setlocale_buf) {
+        Safefree(PL_setlocale_buf);
+        PL_setlocale_buf = NULL;
+    }
+
+    if (PL_langinfo_buf) {
+        Safefree(PL_langinfo_buf);
+        PL_langinfo_buf = NULL;
+    }
+
+    if (PL_stdize_locale_buf) {
+        Safefree(PL_stdize_locale_buf);
+        PL_stdize_locale_buf = NULL;
+    }
+
+#ifdef USE_LOCALE_CTYPE
+    SvREFCNT_dec(PL_warn_locale);
+    PL_warn_locale = NULL;
+#endif
+#ifdef USE_LOCALE_COLLATE
+    Safefree(PL_collation_name);
+    PL_collation_name = NULL;
+#endif
+#ifdef USE_LOCALE_NUMERIC
+    Safefree(PL_numeric_name);
+    PL_numeric_name = NULL;
+    SvREFCNT_dec(PL_numeric_radix_sv);
+    PL_numeric_radix_sv = NULL;
+#endif
+
 }
 
 /*

perl.c

@@ -1113,74 +1113,7 @@ perl_destruct(pTHXx)
     PL_bodytarget = NULL;
     PL_formtarget = NULL;
 
-    /* free locale stuff */
-#ifdef USE_LOCALE_COLLATE
-    Safefree(PL_collation_name);
-    PL_collation_name = NULL;
-#endif
-#if   defined(USE_POSIX_2008_LOCALE)      \
- &&   defined(USE_THREAD_SAFE_LOCALE)     \
- && ! defined(HAS_QUERYLOCALE)
-    for (i = 0; i < (int) C_ARRAY_LENGTH(PL_curlocales); i++) {
-        Safefree(PL_curlocales[i]);
-        PL_curlocales[i] = NULL;
-    }
-#endif
-#ifdef USE_POSIX_2008_LOCALE
-    {
-        /* 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
-        ) {
-            DEBUG_Lv(PerlIO_printf(Perl_debug_log,
-                     "%s:%d: Freeing %p\n", __FILE__, __LINE__, old_locale));
-            freelocale(old_locale);
-        }
-    }
-    if (PL_scratch_locale_obj) {
-        freelocale(PL_scratch_locale_obj);
-        PL_scratch_locale_obj = NULL;
-    }
-#  ifdef USE_LOCALE_NUMERIC
-    if (PL_underlying_numeric_obj) {
-        DEBUG_Lv(PerlIO_printf(Perl_debug_log,
-                    "%s:%d: Freeing %p\n", __FILE__, __LINE__,
-                    PL_underlying_numeric_obj));
-        freelocale(PL_underlying_numeric_obj);
-        PL_underlying_numeric_obj = (locale_t) NULL;
-    }
-#  endif
-#endif
-#ifdef USE_LOCALE_NUMERIC
-    Safefree(PL_numeric_name);
-    PL_numeric_name = NULL;
-    SvREFCNT_dec(PL_numeric_radix_sv);
-    PL_numeric_radix_sv = NULL;
-#endif
-
-    if (PL_setlocale_buf) {
-        Safefree(PL_setlocale_buf);
-        PL_setlocale_buf = NULL;
-    }
-
-    if (PL_langinfo_buf) {
-        Safefree(PL_langinfo_buf);
-        PL_langinfo_buf = NULL;
-    }
-
-    if (PL_stdize_locale_buf) {
-        Safefree(PL_stdize_locale_buf);
-        PL_stdize_locale_buf = NULL;
-    }
-
-#ifdef USE_LOCALE_CTYPE
-    SvREFCNT_dec(PL_warn_locale);
-    PL_warn_locale       = NULL;
-#endif
+    thread_locale_term(false /* Is from perl destruct */);
 
     SvREFCNT_dec(PL_AboveLatin1);
     PL_AboveLatin1 = NULL;

proto.h

@@ -4348,9 +4348,9 @@ PERL_CALLCONV void	Perl_taint_env(pTHX);
 PERL_CALLCONV void	Perl_taint_proper(pTHX_ const char* f, const char *const s);
 #define PERL_ARGS_ASSERT_TAINT_PROPER	\
 	assert(s)
-PERL_CALLCONV void	Perl_thread_locale_init(void);
+PERL_CALLCONV void	Perl_thread_locale_init(pTHX);
 #define PERL_ARGS_ASSERT_THREAD_LOCALE_INIT
-PERL_CALLCONV void	Perl_thread_locale_term(void);
+PERL_CALLCONV void	Perl_thread_locale_term(pTHX_ const bool caller_is_thread_termination);
 #define PERL_ARGS_ASSERT_THREAD_LOCALE_TERM
 PERL_CALLCONV OP *	Perl_tied_method(pTHX_ SV *methname, SV **sp, SV *const sv, const MAGIC *const mg, const U32 flags, U32 argc, ...)
 			__attribute__visibility__("hidden");