Switch libc per-interpreter data when tTHX changes

As noted in the previous commit, some library functions now keep
per-thread state.  So far the only ones we care about are libc
locale-changing ones.

When perl changes threads by swapping out tTHX, those library functions
need to be informed about the new value so that they remain in sync with
what perl thinks the locale should be.

This commit creates a function to do this, and changes the
thread-changing macros to also call this as part of the change.

For POSIX 2008, the function just calls uselocale() using the
per-interpreter object introduced previously.

For Windows, this commit adds a per-interpreter string of the current
LC_ALL, and the function calls setlocale on that.  We keep the same
string for POSIX 2008 implementations that lack querylocale(), so this
commit just enables that variable on Windows as well.  The code is
already in place to free the memory the string occupies when done.

The commit also creates a mechanism to skip this during thread
destruction.  A thread in its death throes doesn't need to have accurate
locale information, and the information needed to map from thread to
what libc needs to know gets destroyed as part of those throes, while
relics of the thread remain.  I couldn't find a way to accurately know
if we are dealing with a relic or not, so the solution I adopted was to
just not switch during destruction.

This commit completes fixing #20155.

diff --git a/dist/threads/lib/threads.pm b/dist/threads/lib/threads.pm
index bbbcb70..6739bca 100644 (file)
--- a/dist/threads/lib/threads.pm
+++ b/dist/threads/lib/threads.pm
@@ -5,7 +5,7 @@ use 5.008;
 use strict;
 use warnings;
 
-our $VERSION = '2.29';      # remember to update version in POD!
+our $VERSION = '2.31';      # remember to update version in POD!
 my $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 
@@ -134,7 +134,7 @@ threads - Perl interpreter-based threads
 
 =head1 VERSION
 
-This document describes threads version 2.29
+This document describes threads version 2.31
 
 =head1 WARNING
 

diff --git a/dist/threads/threads.xs b/dist/threads/threads.xs
index b4fa112..5d26613 100644 (file)
--- a/dist/threads/threads.xs
+++ b/dist/threads/threads.xs
@@ -241,11 +241,20 @@ S_ithread_clear(pTHX_ ithread *thread)
     S_block_most_signals(&origmask);
 #endif
 
+    int save_veto = PL_veto_switch_non_tTHX_context;
+
     interp = thread->interp;
     if (interp) {
         dTHXa(interp);
 
+        /* We will pretend to be a thread that we are not by switching tTHX,
+         * which doesn't work with things that don't rely on tTHX during
+         * tear-down, as they will tend to rely on a mapping from the tTHX
+         * structure, and that structure is being destroyed. */
+        PL_veto_switch_non_tTHX_context = true;
+
         PERL_SET_CONTEXT(interp);
+
         S_ithread_set(aTHX_ thread);
 
         SvREFCNT_dec(thread->params);
@@ -262,6 +271,8 @@ S_ithread_clear(pTHX_ ithread *thread)
     }
 
     PERL_SET_CONTEXT(aTHX);
+    PL_veto_switch_non_tTHX_context = save_veto;
+
 #ifdef THREAD_SIGNAL_BLOCKING
     S_set_sigmask(&origmask);
 #endif

diff --git a/embed.fnc b/embed.fnc
index 7623b3c..5aa07e1 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1665,6 +1665,9 @@ Apd       |void   |switch_to_global_locale
 Apd    |bool   |sync_locale
 Apx    |void   |thread_locale_init
 Apx    |void   |thread_locale_term
+#ifdef USE_PERL_SWITCH_LOCALE_CONTEXT
+CopT   |void   |switch_locale_context
+#endif
 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)

diff --git a/locale.c b/locale.c
index 228b7c5..57744f9 100644 (file)
--- a/locale.c
+++ b/locale.c
@@ -2601,7 +2601,6 @@ S_win32_setlocale(pTHX_ int category, const char* locale)
      * use the particular category's variable if set; otherwise to use the LANG
      * variable. */
 
-
     if (locale == NULL) {
         return wrap_wsetlocale(category, NULL);
     }
@@ -2615,6 +2614,20 @@ S_win32_setlocale(pTHX_ int category, const char* locale)
     const char * result = wrap_wsetlocale(category, locale);
     DEBUG_L(PerlIO_printf(Perl_debug_log, "%s\n",
                           setlocale_debug_string_r(category, locale, result)));
+
+#  ifdef USE_PL_CUR_LC_ALL
+
+    /* If we need to keep track of LC_ALL, update it to the new value.  */
+    Safefree(PL_cur_LC_ALL);
+    if (category == LC_ALL) {
+        PL_cur_LC_ALL = savepv(result);
+    }
+    else {
+        PL_cur_LC_ALL = savepv(setlocale(LC_ALL, NULL));
+    }
+
+#  endif
+
     return result;
 }
 
@@ -6723,6 +6736,46 @@ S_my_setlocale_debug_string_i(pTHX_
 }
 
 #endif
+#ifdef USE_PERL_SWITCH_LOCALE_CONTEXT
+
+void
+Perl_switch_locale_context()
+{
+    /* libc keeps per-thread locale status information in some configurations.
+     * So, we can't just switch out aTHX to switch to a new thread.  libc has
+     * to follow along.  This routine does that based on per-interpreter
+     * variables we keep just for this purpose */
+
+    /* Can't use pTHX, because we may be called from a place where that
+     * isn't available */
+    dTHX;
+
+    if (UNLIKELY(   aTHX == NULL
+                 || PL_veto_switch_non_tTHX_context
+                 || PL_phase == PERL_PHASE_CONSTRUCT))
+    {
+        return;
+    }
+
+#  ifdef USE_POSIX_2008_LOCALE
+
+    if (! uselocale(PL_cur_locale_obj)) {
+        locale_panic_(Perl_form(aTHX_
+                                "Can't uselocale(%p), LC_ALL supposed to be '%s",
+                                PL_cur_locale_obj, get_LC_ALL_display()));
+    }
+
+#  elif defined(WIN32)
+
+    if (! bool_setlocale_c(LC_ALL, PL_cur_LC_ALL)) {
+        locale_panic_(Perl_form(aTHX_ "Can't setlocale(%s)", PL_cur_LC_ALL));
+    }
+
+#  endif
+
+}
+
+#endif
 
 void
 Perl_thread_locale_init(pTHX)

diff --git a/makedef.pl b/makedef.pl
index 58918ca..70419e1 100644 (file)
--- a/makedef.pl
+++ b/makedef.pl
@@ -177,11 +177,20 @@ if ($define{USE_POSIX_2008_LOCALE} && ! $define{USE_QUERYLOCALE})
 
 if ($ARGS{PLATFORM} eq 'win32' && $define{USE_THREAD_SAFE_LOCALE})
 {
+    $define{USE_PL_CUR_LC_ALL} = 1;
+
     if ($cctype < 140) {
         $define{TS_W32_BROKEN_LOCALECONV} = 1;
     }
 }
 
+if ($define{MULTIPLICITY} && (   $define{USE_POSIX_2008_LOCALE}
+                                || (   $define{WIN32}
+                                    && $define{USE_THREAD_SAFE_LOCALE})))
+{
+    $define{USE_PERL_SWITCH_LOCALE_CONTEXT}
+}
+
 # perl.h logic duplication ends
 #==========================================================================
 
@@ -400,6 +409,7 @@ unless ($define{'USE_ITHREADS'}) {
                    PL_stashpad
                    PL_stashpadix
                    PL_stashpadmax
+                    PL_veto_switch_non_tTHX_context
                    Perl_alloccopstash
                    Perl_allocfilegv
                    Perl_clone_params_del
@@ -450,6 +460,13 @@ unless ($define{USE_PL_CUR_LC_ALL})
     );
 }
 
+unless ($define{USE_PERL_SWITCH_LOCALE_CONTEXT})
+{
+    ++$skip{$_} foreach qw(
+        Perl_switch_locale_context
+    );
+}
+
 unless ($define{'MULTIPLICITY'}) {
     ++$skip{$_} foreach qw(
                    PL_my_cxt_index

diff --git a/perl.h b/perl.h
index 7fe8b46..07fd747 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1272,6 +1272,11 @@ violations are fatal.
 
 #  if defined(WIN32) && defined(USE_THREAD_SAFE_LOCALE)
 
+   /* We need to be able to map the current value of what the tTHX context
+    * thinks LC_ALL is so as to inform the Windows libc when switching
+    * contexts. */
+#    define USE_PL_CUR_LC_ALL
+
    /* Microsoft documentation reads in the change log for VS 2015: "The
     * localeconv function declared in locale.h now works correctly when
     * per-thread locale is enabled. In previous versions of the library, this
@@ -1281,6 +1286,15 @@ violations are fatal.
 #      define TS_W32_BROKEN_LOCALECONV
 #    endif
 #  endif
+
+   /* POSIX 2008 and Windows with thread-safe locales keep locale information
+    * in libc data.  Therefore we must inform their libc's when the context
+    * switches */
+#  if defined(MULTIPLICITY) && (   defined(USE_POSIX_2008_LOCALE)           \
+                                || (   defined(WIN32)                       \
+                                    && defined(USE_THREAD_SAFE_LOCALE)))
+#    define USE_PERL_SWITCH_LOCALE_CONTEXT
+#  endif
 #endif
 
 /* end of makedef.pl logic duplication
@@ -4046,7 +4060,10 @@ out there, Solaris being the most prominent.
 
 /* the traditional thread-unsafe notion of "current interpreter". */
 #ifndef PERL_SET_INTERP
-#  define PERL_SET_INTERP(i)           (PL_curinterp = (PerlInterpreter*)(i))
+#  define PERL_SET_INTERP(i)                                            \
+            STMT_START { PL_curinterp = (PerlInterpreter*)(i);          \
+                         PERL_SET_NON_tTHX_CONTEXT(i);                  \
+            } STMT_END
 #endif
 
 #ifndef PERL_GET_INTERP
@@ -6273,6 +6290,24 @@ EXTCONST U8   PL_deBruijn_bitpos_tab64[];
 #  define PERL_SET_CONTEXT(i)          PERL_SET_INTERP(i)
 #endif
 
+#ifdef USE_PERL_SWITCH_LOCALE_CONTEXT
+#  define PERL_SET_LOCALE_CONTEXT(i)                                        \
+      STMT_START {                                                          \
+          if (UNLIKELY(PL_veto_switch_non_tTHX_context))                    \
+                Perl_switch_locale_context();                               \
+      } STMT_END
+#else
+#  define PERL_SET_LOCALE_CONTEXT(i)  NOOP
+#endif
+
+/* In some Configurations there may be per-thread information that is carried
+ * in a library instead of perl's tTHX structure.  This macro is to be used to
+ * handle those when tTHX is changed.  Only locale handling is currently known
+ * to be affected. */
+#define PERL_SET_NON_tTHX_CONTEXT(i)                                        \
+                        STMT_START { PERL_SET_LOCALE_CONTEXT(i); } STMT_END
+
+
 #ifndef PERL_GET_CONTEXT
 #  define PERL_GET_CONTEXT             PERL_GET_INTERP
 #endif
@@ -7883,7 +7918,9 @@ C<strtoul>.
  *    "DynaLoader::_guts" XS_VERSION
  *    XXX in the current implementation, this string is ignored.
  * 2. Declare a typedef named my_cxt_t that is a structure that contains
- *    all the data that needs to be interpreter-local.
+ *    all the data that needs to be interpreter-local that perl controls.  This
+ *    doesn't include things that libc controls, such as the uselocale object
+ *    in Configurations that use it.
  * 3. Use the START_MY_CXT macro after the declaration of my_cxt_t.
  * 4. Use the MY_CXT_INIT macro such that it is called exactly once
  *    (typically put in the BOOT: section).

diff --git a/perlvars.h b/perlvars.h
index 416f3d0..0df71f5 100644 (file)
--- a/perlvars.h
+++ b/perlvars.h
@@ -169,6 +169,7 @@ PERLVAR(G, check_mutex,     perl_mutex)     /* Mutex for PL_check */
 #ifdef MULTIPLICITY
 # ifdef USE_ITHREADS
 PERLVAR(G, my_ctx_mutex, perl_mutex)
+PERLVARI(G, veto_switch_non_tTHX_context, int, FALSE)
 # endif
 PERLVARI(G, my_cxt_index, int, 0)
 #endif

diff --git a/proto.h b/proto.h
index 853961e..9f11310 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -7661,6 +7661,10 @@ PERL_CALLCONV SSize_t    Perl_PerlIO_write(pTHX_ PerlIO *f, const void *vbuf, Size_
 #define PERL_ARGS_ASSERT_PERLIO_WRITE  \
        assert(vbuf)
 #endif
+#if defined(USE_PERL_SWITCH_LOCALE_CONTEXT)
+PERL_CALLCONV void     Perl_switch_locale_context(void);
+#define PERL_ARGS_ASSERT_SWITCH_LOCALE_CONTEXT
+#endif
 #if defined(USE_QUADMATH)
 PERL_CALLCONV bool     Perl_quadmath_format_needed(const char* format)
                        __attribute__visibility__("hidden");

diff --git a/thread.h b/thread.h
index 54d9866..5a2b3af 100644 (file)
--- a/thread.h
+++ b/thread.h
@@ -404,6 +404,7 @@ extern PERL_THREAD_LOCAL void *PL_current_context;
                                         PL_current_context = (void *)(t)))) \
             Perl_croak_nocontext("panic: pthread_setspecific (%d) [%s:%d]", \
                                  _eC_, __FILE__, __LINE__);                 \
+        PERL_SET_NON_tTHX_CONTEXT(t);                                       \
     } STMT_END
 
 #else

diff --git a/util.c b/util.c
index 9022149..aa3a1ae 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3740,6 +3740,9 @@ Perl_set_context(void *t)
             Perl_croak_nocontext("panic: pthread_setspecific, error=%d", error);
     }
 #  endif
+
+    PERL_SET_NON_tTHX_CONTEXT(t);
+
 #else
     PERL_UNUSED_ARG(t);
 #endif