diff options
| -rw-r--r-- | dist/threads/lib/threads.pm | 4 | ||||
| -rw-r--r-- | dist/threads/threads.xs | 11 | ||||
| -rw-r--r-- | embed.fnc | 3 | ||||
| -rw-r--r-- | locale.c | 55 | ||||
| -rw-r--r-- | makedef.pl | 17 | ||||
| -rw-r--r-- | perl.h | 41 | ||||
| -rw-r--r-- | perlvars.h | 1 | ||||
| -rw-r--r-- | proto.h | 4 | ||||
| -rw-r--r-- | thread.h | 1 | ||||
| -rw-r--r-- | util.c | 3 |
10 files changed, 135 insertions, 5 deletions
diff --git a/dist/threads/lib/threads.pm b/dist/threads/lib/threads.pm index bbbcb70b69..6739bca9a0 100644 --- 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 b4fa1121ed..5d2661338f 100644 --- 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 @@ -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) @@ -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 58918ca47b..70419e19af 100644 --- 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 @@ -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 416f3d041c..0df71f50a7 100644 --- 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 @@ -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"); @@ -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 @@ -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 |