Latch LC_NUMERIC during critical sections
authorKarl Williamson <khw@cpan.org>
Tue, 13 Feb 2018 20:12:50 +0000 (13:12 -0700)
committerKarl Williamson <khw@cpan.org>
Sun, 18 Feb 2018 22:44:23 +0000 (15:44 -0700)
It is possible for operations on threaded perls which don't 'use locale'
to still change the locale.  This happens when calling
POSIX::localeconv() and I18N::Langinfo(), and in earlier perls, it can
happen for other operations when perl has been initialized with the
environment causing the various locale categories to not have a uniform
locale.

This commit causes the areas where the locale for this category should
predictably be in one or the other state to be a critical section where
another thread can't interrupt and change it.  This is a separate
mutex, so that only these particular operations will be held up.

dist/ExtUtils-ParseXS/lib/perlxs.pod
embedvar.h
intrpvar.h
makedef.pl
perl.h
perlapi.h
perlvars.h
sv.c
vutil.c

index 78297c2..2011ac8 100644 (file)
@@ -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
 
index d7eb929..d8b09fe 100644 (file)
 #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)
 #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)
index 884fa87..dec6fa9 100644 (file)
@@ -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
index aabdaa7..aa3d8c4 100644 (file)
@@ -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
diff --git a/perl.h b/perl.h
index 05ceff4..403aca8 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -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) {              \
index c461593..b39c8cc 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -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
index 708bade..be67a59 100644 (file)
@@ -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
 
diff --git a/sv.c b/sv.c
index 4377e95..2c3da0f 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -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;
 
diff --git a/vutil.c b/vutil.c
index 282da24..af5f263 100644 (file)
--- a/vutil.c
+++ b/vutil.c
@@ -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 */