diff options
| -rw-r--r-- | dist/ExtUtils-ParseXS/lib/perlxs.pod | 14 | ||||
| -rw-r--r-- | embedvar.h | 3 | ||||
| -rw-r--r-- | intrpvar.h | 1 | ||||
| -rw-r--r-- | makedef.pl | 1 | ||||
| -rw-r--r-- | perl.h | 175 | ||||
| -rw-r--r-- | perlapi.h | 2 | ||||
| -rw-r--r-- | perlvars.h | 1 | ||||
| -rw-r--r-- | sv.c | 1 | ||||
| -rw-r--r-- | vutil.c | 6 |
9 files changed, 166 insertions, 38 deletions
diff --git a/dist/ExtUtils-ParseXS/lib/perlxs.pod b/dist/ExtUtils-ParseXS/lib/perlxs.pod index 78297c276c..2011ac890a 100644 --- a/dist/ExtUtils-ParseXS/lib/perlxs.pod +++ b/dist/ExtUtils-ParseXS/lib/perlxs.pod @@ -2223,8 +2223,14 @@ handled. If the locale from the user's environment is desired, there should be no need for XS code to set the locale except for C<LC_NUMERIC>, as perl has -already set it up. XS code should avoid changing the locale, as it can -adversely affect other, unrelated, code and may not be thread safe. +already set the others up. XS code should avoid changing the locale, as +it can adversely affect other, unrelated, code and may not be +thread-safe. To minimize problems, the macros +L<perlapi/STORE_LC_NUMERIC_SET_TO_NEEDED>, +L<perlapi/STORE_LC_NUMERIC_FORCE_TO_UNDERLYING>, and +L<perlapi/RESTORE_LC_NUMERIC> should be used to affect any needed +change. + However, some alien libraries that may be called do set it, such as C<Gtk>. This can cause problems for the perl core and other modules. Starting in v5.20.1, calling the function @@ -2234,9 +2240,7 @@ statement that does this: POSIX::setlocale(LC_ALL, POSIX::setlocale(LC_ALL)); -In the event that your XS code may need the underlying C<LC_NUMERIC> -locale, there are macros available to access this; see -L<perlapi/Locale-related functions and macros>. +or use the methods given in L<perlcall>. =back diff --git a/embedvar.h b/embedvar.h index d7eb929aa5..d8b09fe35b 100644 --- a/embedvar.h +++ b/embedvar.h @@ -187,6 +187,7 @@ #define PL_lastgotoprobe (vTHX->Ilastgotoprobe) #define PL_laststatval (vTHX->Ilaststatval) #define PL_laststype (vTHX->Ilaststype) +#define PL_lc_numeric_mutex_depth (vTHX->Ilc_numeric_mutex_depth) #define PL_locale_utf8ness (vTHX->Ilocale_utf8ness) #define PL_localizing (vTHX->Ilocalizing) #define PL_localpatches (vTHX->Ilocalpatches) @@ -406,6 +407,8 @@ #define PL_Gkeyword_plugin (my_vars->Gkeyword_plugin) #define PL_keyword_plugin_mutex (my_vars->Gkeyword_plugin_mutex) #define PL_Gkeyword_plugin_mutex (my_vars->Gkeyword_plugin_mutex) +#define PL_lc_numeric_mutex (my_vars->Glc_numeric_mutex) +#define PL_Glc_numeric_mutex (my_vars->Glc_numeric_mutex) #define PL_locale_mutex (my_vars->Glocale_mutex) #define PL_Glocale_mutex (my_vars->Glocale_mutex) #define PL_malloc_mutex (my_vars->Gmalloc_mutex) diff --git a/intrpvar.h b/intrpvar.h index 884fa87dc6..dec6fa93c6 100644 --- a/intrpvar.h +++ b/intrpvar.h @@ -262,6 +262,7 @@ PERLVAR(I, exit_flags, U8) /* was exit() unexpected, etc. */ PERLVAR(I, utf8locale, bool) /* utf8 locale detected */ PERLVAR(I, in_utf8_CTYPE_locale, bool) PERLVAR(I, in_utf8_COLLATE_locale, bool) +PERLVARI(I, lc_numeric_mutex_depth, int, 0) /* Emulate general semaphore */ PERLVARA(I, locale_utf8ness, 256, char) #ifdef USE_LOCALE_CTYPE diff --git a/makedef.pl b/makedef.pl index aabdaa78ee..aa3d8c48ee 100644 --- a/makedef.pl +++ b/makedef.pl @@ -366,6 +366,7 @@ unless ($define{'USE_ITHREADS'}) { PL_dollarzero_mutex PL_hints_mutex PL_locale_mutex + PL_lc_numeric_mutex PL_my_ctx_mutex PL_perlio_mutex PL_stashpad @@ -5556,14 +5556,89 @@ typedef struct am_table_short AMTS; # define LOCALE_INIT # define LOCALE_LOCK # define LOCALE_UNLOCK +# define LC_NUMERIC_LOCK(cond) +# define LC_NUMERIC_UNLOCK # define LOCALE_TERM STMT_START { _LOCALE_TERM_POSIX_2008; } STMT_END -# else /* Below is do use threads */ -# define LOCALE_INIT MUTEX_INIT(&PL_locale_mutex) +# else +# define LOCALE_INIT STMT_START { \ + MUTEX_INIT(&PL_locale_mutex); \ + MUTEX_INIT(&PL_lc_numeric_mutex); \ + } STMT_END + +/* This mutex is used to create critical sections where we want the LC_NUMERIC + * locale to be locked into either the C (standard) locale, or the underlying + * locale, so that other threads interrupting this one don't change it to the + * wrong state before we've had a chance to complete our operation. It can + * stay locked over an entire printf operation, for example. And so is made + * distinct from the LOCALE_LOCK mutex. + * + * This simulates kind of a general semaphore. The current thread will lock + * the mutex if the per-thread variable is zero, and then increments that + * variable. Each corresponding UNLOCK decrements the variable until it is 0, + * at which point it actually unlocks the mutex. Since the variable is + * per-thread, there is no race with other threads. + * + * The single argument is a condition to test for, and if true, to panic, as + * this would be an attempt to complement the LC_NUMERIC state, and we're not + * supposed to because it's locked */ +# define LC_NUMERIC_LOCK(cond_to_panic_if_already_locked) \ + STMT_START { \ + if (PL_lc_numeric_mutex_depth <= 0) { \ + MUTEX_LOCK(&PL_lc_numeric_mutex); \ + PL_lc_numeric_mutex_depth = 1; \ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ + "%s: %d: locking lc_numeric; depth=1\n", \ + __FILE__, __LINE__)); \ + } \ + else { \ + PL_lc_numeric_mutex_depth++; \ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ + "%s: %d: avoided lc_numeric_lock; depth=%d\n", \ + __FILE__, __LINE__, PL_lc_numeric_mutex_depth)); \ + if (cond_to_panic_if_already_locked) { \ + Perl_croak_nocontext("panic: %s: %d: Trying to change" \ + " LC_NUMERIC incompatibly", \ + __FILE__, __LINE__); \ + } \ + } \ + } STMT_END + +# define LC_NUMERIC_UNLOCK \ + STMT_START { \ + if (PL_lc_numeric_mutex_depth <= 1) { \ + MUTEX_UNLOCK(&PL_lc_numeric_mutex); \ + PL_lc_numeric_mutex_depth = 0; \ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ + "%s: %d: unlocking lc_numeric; depth=0\n", \ + __FILE__, __LINE__)); \ + } \ + else { \ + PL_lc_numeric_mutex_depth--; \ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, \ + "%s: %d: avoided lc_numeric_unlock; depth=%d\n", \ + __FILE__, __LINE__, PL_lc_numeric_mutex_depth)); \ + } \ + } STMT_END + +/* This is used as a generic lock for locale operations. For example this is + * used when calling nl_langinfo() so that another thread won't zap the + * contents of its buffer before it gets saved; and it's called when changing + * the locale of LC_MESSAGES. On some systems the latter can cause the + * nl_langinfo buffer to be zapped under a race condition. + * + * If combined with LC_NUMERIC_LOCK, calls to this and its corresponding unlock + * should be contained entirely within the locked portion of LC_NUMERIC. This + * mutex should be used only in very short sections of code, while + * LC_NUMERIC_LOCK may span more operations. By always following this + * convention, deadlock should be impossible. But if necessary, the two + * mutexes could be combined */ # define LOCALE_LOCK MUTEX_LOCK(&PL_locale_mutex) # define LOCALE_UNLOCK MUTEX_UNLOCK(&PL_locale_mutex) + # define LOCALE_TERM \ STMT_START { \ MUTEX_DESTROY(&PL_locale_mutex); \ + MUTEX_DESTROY(&PL_lc_numeric_mutex); \ _LOCALE_TERM_POSIX_2008; \ } STMT_END # ifdef HAS_POSIX_2008_LOCALE @@ -5719,6 +5794,9 @@ argument list, like this: The private variable is used to save the current locale state, so that the requisite matching call to L</RESTORE_LC_NUMERIC> can restore it. +On threaded perls, this macro uses a mutex to force a critical section. +Therefore the matching RESTORE should be close by, and guaranteed to be called. + =for apidoc Am|void|STORE_LC_NUMERIC_SET_TO_NEEDED This is used to help wrap XS or C code that that is C<LC_NUMERIC> locale-aware. @@ -5749,6 +5827,9 @@ argument list, like this: ... } +On threaded perls, this macro uses a mutex to force a critical section. +Therefore the matching RESTORE should be close by, and guaranteed to be called. + =for apidoc Am|void|RESTORE_LC_NUMERIC This is used in conjunction with one of the macros @@ -5798,56 +5879,84 @@ expression, but with an empty argument list, like this: void (*_restore_LC_NUMERIC_function)(pTHX) = NULL # define STORE_LC_NUMERIC_SET_TO_NEEDED() \ - if (IN_LC(LC_NUMERIC)) { \ - if (_NOT_IN_NUMERIC_UNDERLYING) { \ - Perl_set_numeric_underlying(aTHX); \ - _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \ - } \ - } \ - else { \ - if (_NOT_IN_NUMERIC_STANDARD) { \ - SET_NUMERIC_STANDARD(); \ - _restore_LC_NUMERIC_function = &Perl_set_numeric_underlying; \ - } \ - } + STMT_START { \ + LC_NUMERIC_LOCK( \ + (IN_LC(LC_NUMERIC) && _NOT_IN_NUMERIC_UNDERLYING) \ + || _NOT_IN_NUMERIC_STANDARD); \ + if (IN_LC(LC_NUMERIC)) { \ + if (_NOT_IN_NUMERIC_UNDERLYING) { \ + Perl_set_numeric_underlying(aTHX); \ + _restore_LC_NUMERIC_function \ + = &Perl_set_numeric_standard; \ + } \ + } \ + else { \ + if (_NOT_IN_NUMERIC_STANDARD) { \ + Perl_set_numeric_standard(aTHX); \ + _restore_LC_NUMERIC_function \ + = &Perl_set_numeric_underlying; \ + } \ + } \ + } STMT_END # define RESTORE_LC_NUMERIC() \ - if (_restore_LC_NUMERIC_function) { \ - _restore_LC_NUMERIC_function(aTHX); \ - } + STMT_START { \ + if (_restore_LC_NUMERIC_function) { \ + _restore_LC_NUMERIC_function(aTHX); \ + } \ + LC_NUMERIC_UNLOCK; \ + } STMT_END /* The next two macros set unconditionally. These should be rarely used, and * only after being sure that this is what is needed */ # define SET_NUMERIC_STANDARD() \ - STMT_START { if (_NOT_IN_NUMERIC_STANDARD) \ - Perl_set_numeric_standard(aTHX); \ - } STMT_END + STMT_START { \ + DEBUG_Lv(PerlIO_printf(Perl_debug_log,"%s: %d: standard=%d\n", \ + __FILE__, __LINE__, PL_numeric_standard)); \ + Perl_set_numeric_standard(aTHX); \ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: standard=%d\n", \ + __FILE__, __LINE__, PL_numeric_standard)); \ + } STMT_END # define SET_NUMERIC_UNDERLYING() \ - STMT_START { if (_NOT_IN_NUMERIC_UNDERLYING) \ - Perl_set_numeric_underlying(aTHX); } STMT_END + STMT_START { \ + if (_NOT_IN_NUMERIC_UNDERLYING) { \ + Perl_set_numeric_underlying(aTHX); \ + } \ + } STMT_END /* The rest of these LC_NUMERIC macros toggle to one or the other state, with * the RESTORE_foo ones called to switch back, but only if need be */ # define STORE_LC_NUMERIC_SET_STANDARD() \ - if (_NOT_IN_NUMERIC_STANDARD) { \ - _restore_LC_NUMERIC_function = &Perl_set_numeric_underlying; \ - Perl_set_numeric_standard(aTHX); \ - } + STMT_START { \ + LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_STANDARD); \ + if (_NOT_IN_NUMERIC_STANDARD) { \ + _restore_LC_NUMERIC_function = &Perl_set_numeric_underlying;\ + Perl_set_numeric_standard(aTHX); \ + } \ + } STMT_END /* Rarely, we want to change to the underlying locale even outside of 'use * locale'. This is principally in the POSIX:: functions */ # define STORE_LC_NUMERIC_FORCE_TO_UNDERLYING() \ - if (_NOT_IN_NUMERIC_UNDERLYING) { \ - Perl_set_numeric_underlying(aTHX); \ - _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \ - } + STMT_START { \ + LC_NUMERIC_LOCK(_NOT_IN_NUMERIC_UNDERLYING); \ + if (_NOT_IN_NUMERIC_UNDERLYING) { \ + Perl_set_numeric_underlying(aTHX); \ + _restore_LC_NUMERIC_function = &Perl_set_numeric_standard; \ + } \ + } STMT_END /* Lock/unlock to the C locale until unlock is called. This needs to be * recursively callable. [perl #128207] */ -# define LOCK_LC_NUMERIC_STANDARD() \ - (__ASSERT_(PL_numeric_standard) \ - PL_numeric_standard++) +# define LOCK_LC_NUMERIC_STANDARD() \ + STMT_START { \ + DEBUG_Lv(PerlIO_printf(Perl_debug_log, "%s: %d: standard=%d\n", \ + __FILE__, __LINE__, PL_numeric_standard)); \ + __ASSERT_(PL_numeric_standard) \ + PL_numeric_standard++; \ + } STMT_END + # define UNLOCK_LC_NUMERIC_STANDARD() \ STMT_START { \ if (PL_numeric_standard > 1) { \ @@ -131,6 +131,8 @@ END_EXTERN_C #define PL_keyword_plugin (*Perl_Gkeyword_plugin_ptr(NULL)) #undef PL_keyword_plugin_mutex #define PL_keyword_plugin_mutex (*Perl_Gkeyword_plugin_mutex_ptr(NULL)) +#undef PL_lc_numeric_mutex +#define PL_lc_numeric_mutex (*Perl_Glc_numeric_mutex_ptr(NULL)) #undef PL_locale_mutex #define PL_locale_mutex (*Perl_Glocale_mutex_ptr(NULL)) #undef PL_malloc_mutex diff --git a/perlvars.h b/perlvars.h index 708badef07..be67a59988 100644 --- a/perlvars.h +++ b/perlvars.h @@ -100,6 +100,7 @@ PERLVARI(G, mmap_page_size, IV, 0) #if defined(USE_ITHREADS) PERLVAR(G, hints_mutex, perl_mutex) /* Mutex for refcounted he refcounting */ PERLVAR(G, locale_mutex, perl_mutex) /* Mutex for setlocale() changing */ +PERLVAR(G, lc_numeric_mutex, perl_mutex) /* Mutex for switching LC_NUMERIC */ #endif @@ -15235,6 +15235,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_in_utf8_CTYPE_locale = proto_perl->Iin_utf8_CTYPE_locale; PL_in_utf8_COLLATE_locale = proto_perl->Iin_utf8_COLLATE_locale; my_strlcpy(PL_locale_utf8ness, proto_perl->Ilocale_utf8ness, sizeof(PL_locale_utf8ness)); + PL_lc_numeric_mutex_depth = 0; /* Unicode features (see perlrun/-C) */ PL_unicode = proto_perl->Iunicode; @@ -628,6 +628,8 @@ VER_NV: /* if it isn't C, set it to C. */ const char * locale_name_on_entry; + LC_NUMERIC_LOCK(0); /* Start critical section */ + locale_name_on_entry = setlocale(LC_NUMERIC, NULL); if ( strNE(locale_name_on_entry, "C") && strNE(locale_name_on_entry, "POSIX")) @@ -638,6 +640,7 @@ VER_NV: change the locale */ locale_name_on_entry = NULL; } + /* Prevent recursed calls from trying to change back */ LOCK_LC_NUMERIC_STANDARD(); @@ -660,6 +663,9 @@ VER_NV: if (locale_name_on_entry) { setlocale(LC_NUMERIC, locale_name_on_entry); } + + LC_NUMERIC_UNLOCK; /* End critical section */ + } #endif /* USE_LOCALE_NUMERIC */ |