Make the locale mutex a general semaphore

Future commits will use this new capability, and in Configurations where
no locale locking is currently necessary.

6 files changed, 93 insertions, 34 deletions

diff --git a/embedvar.h b/embedvar.h
index 2165582d25..bde83ec087 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -170,6 +170,7 @@
 #define PL_laststatval		(vTHX->Ilaststatval)
 #define PL_laststype		(vTHX->Ilaststype)
 #define PL_lc_numeric_mutex_depth	(vTHX->Ilc_numeric_mutex_depth)
+#define PL_locale_mutex_depth	(vTHX->Ilocale_mutex_depth)
 #define PL_localizing		(vTHX->Ilocalizing)
 #define PL_localpatches		(vTHX->Ilocalpatches)
 #define PL_lockhook		(vTHX->Ilockhook)
diff --git a/intrpvar.h b/intrpvar.h
index bae3b21b7d..0315000fd5 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -387,6 +387,9 @@ PERLVAR(I, utf8locale,	bool)		/* utf8 locale detected */
 PERLVAR(I, in_utf8_CTYPE_locale, bool)
 PERLVAR(I, in_utf8_COLLATE_locale, bool)
 PERLVAR(I, in_utf8_turkic_locale, bool)
+#if defined(USE_LOCALE) && defined(USE_LOCALE_THREADS)
+PERLVARI(I, locale_mutex_depth, int, 0)     /* Emulate general semaphore */
+#endif
 #if defined(USE_ITHREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
 PERLVARI(I, lc_numeric_mutex_depth, int, 0)   /* Emulate general semaphore */
 #endif
diff --git a/locale.c b/locale.c
index d736bcaf9e..1101944206 100644
--- a/locale.c
+++ b/locale.c
@@ -430,9 +430,15 @@ Perl_force_locale_unlock()
 #if defined(USE_LOCALE_THREADS)
 
     dTHX;
-#  ifdef LOCALE_UNLOCK_
-    LOCALE_UNLOCK_;
-#  endif
+
+    /* If recursively locked, clear all at once */
+    if (PL_locale_mutex_depth > 1) {
+        PL_locale_mutex_depth = 1;
+    }
+
+    if (PL_locale_mutex_depth > 0) {
+        LOCALE_UNLOCK_;
+    }
 
 #endif
 
diff --git a/makedef.pl b/makedef.pl
index 6d227d44ff..f91fa8c233 100644
--- a/makedef.pl
+++ b/makedef.pl
@@ -378,6 +378,7 @@ unless ($define{'USE_ITHREADS'}) {
 		    PL_env_mutex
 		    PL_hints_mutex
 		    PL_locale_mutex
+		    PL_locale_mutex_depth
 		    PL_lc_numeric_mutex
 		    PL_lc_numeric_mutex_depth
 		    PL_my_ctx_mutex
diff --git a/perl.h b/perl.h
index bf20bf6441..dea9f22bbf 100644
--- a/perl.h
+++ b/perl.h
@@ -7042,17 +7042,74 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect.
 #define locale_panic_(m)  Perl_locale_panic((m), __FILE__, __LINE__, errno)
 
 /* Locale/thread synchronization macros. */
-#if   (   defined(USE_LOCALE)                                               \
-       &&    defined(USE_LOCALE_THREADS)                                    \
-       && (  ! defined(USE_THREAD_SAFE_LOCALE)                              \
-           || (   defined(HAS_LOCALECONV)                                   \
-               && (  ! defined(HAS_LOCALECONV_L)                            \
-                   ||  defined(TS_W32_BROKEN_LOCALECONV)))                  \
-           || (   defined(HAS_NL_LANGINFO)                                  \
-               && ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L))                 \
-           || (defined(HAS_MBLEN)  && ! defined(HAS_MBRLEN))                \
-           || (defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC))               \
-           || (defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB))))
+#if ! defined(USE_LOCALE) || ! defined(USE_LOCALE_THREADS)
+#  define LOCALE_LOCK_(cond)  NOOP
+#  define LOCALE_UNLOCK_      NOOP
+#  define LOCALE_INIT
+#  define LOCALE_TERM
+
+#else   /* Below: Threaded, and locales are supported */
+
+    /* A locale mutex is required on all such threaded builds.
+     *
+     * This mutex simulates a general (or recursive) 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, initialized to 0, there is no race
+     * with other threads.
+     *
+     * The single argument is a condition to test for, and if true, to panic.
+     * Call it with the constant 0 to suppress the check.
+     *
+     * Clang improperly gives warnings for this, if not silenced:
+     * https://clang.llvm.org/docs/ThreadSafetyAnalysis.html#conditional-locks
+     */
+#  define LOCALE_LOCK_(cond_to_panic_if_already_locked)                     \
+        STMT_START {                                                        \
+            CLANG_DIAG_IGNORE(-Wthread-safety)	     	                    \
+            if (LIKELY(PL_locale_mutex_depth <= 0)) {                       \
+                DEBUG_Lv(PerlIO_printf(Perl_debug_log,                      \
+                         "%s: %d: locking locale; depth=1\n",               \
+                         __FILE__, __LINE__));                              \
+                MUTEX_LOCK(&PL_locale_mutex);                               \
+                PL_locale_mutex_depth = 1;                                  \
+            }                                                               \
+            else {                                                          \
+                PL_locale_mutex_depth++;                                    \
+                DEBUG_Lv(PerlIO_printf(Perl_debug_log,                      \
+                        "%s: %d: avoided locking locale; new depth=%d\n",   \
+                        __FILE__, __LINE__, PL_locale_mutex_depth));        \
+                if (cond_to_panic_if_already_locked) {                      \
+                    locale_panic_("Trying to lock locale incompatibly: "    \
+                         STRINGIFY(cond_to_panic_if_already_locked));       \
+                }                                                           \
+            }                                                               \
+            CLANG_DIAG_RESTORE                                              \
+        } STMT_END
+
+#  define LOCALE_UNLOCK_                                                    \
+        STMT_START {                                                        \
+            if (LIKELY(PL_locale_mutex_depth == 1)) {                       \
+                DEBUG_Lv(PerlIO_printf(Perl_debug_log,                      \
+                         "%s: %d: unlocking locale; new depth=0\n",         \
+                         __FILE__, __LINE__));                              \
+                PL_locale_mutex_depth = 0;                                  \
+                MUTEX_UNLOCK(&PL_locale_mutex);                             \
+            }                                                               \
+            else if (PL_locale_mutex_depth <= 0) {                          \
+                DEBUG_L(PerlIO_printf(Perl_debug_log,                       \
+                        "%s: %d: ignored attempt to unlock already"         \
+                        " unlocked locale; depth unchanged at %d\n",        \
+                       __FILE__, __LINE__, PL_locale_mutex_depth));         \
+            }                                                               \
+            else {                                                          \
+                PL_locale_mutex_depth--;                                    \
+                DEBUG_Lv(PerlIO_printf(Perl_debug_log,                      \
+                        "%s: %d: avoided unlocking locale; new depth=%d\n", \
+                        __FILE__, __LINE__, PL_locale_mutex_depth));        \
+            }                                                               \
+        } STMT_END
 
 #  ifndef USE_POSIX_2008_LOCALE
 #    define LOCALE_TERM_POSIX_2008_  NOOP
@@ -7096,8 +7153,6 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect.
 /* The whole expression just above was complemented, so here we have no need
  * for thread synchronization, most likely it would be that this isn't a
  * threaded build. */
-#  define LOCALE_INIT
-#  define LOCALE_TERM
 #  define LC_NUMERIC_LOCK(cond)     NOOP
 #  define LC_NUMERIC_UNLOCK         NOOP
 #  define LOCALECONV_LOCK           NOOP
@@ -7144,18 +7199,6 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect.
     * will be called frequently, and the locked interval should be short, and
     * modern platforms will have reentrant versions (which don't lock) for
     * almost all of them, so khw thinks a single mutex should suffice. */
-#  define LOCALE_LOCK_                                                      \
-        STMT_START {                                                        \
-            DEBUG_Lv(PerlIO_printf(Perl_debug_log,                          \
-                    "%s: %d: locking locale\n", __FILE__, __LINE__));       \
-            MUTEX_LOCK(&PL_locale_mutex);                                   \
-        } STMT_END
-#  define LOCALE_UNLOCK_                                                    \
-        STMT_START {                                                        \
-            DEBUG_Lv(PerlIO_printf(Perl_debug_log,                          \
-                   "%s: %d: unlocking locale\n", __FILE__, __LINE__));      \
-            MUTEX_UNLOCK(&PL_locale_mutex);                                 \
-        } STMT_END
 
    /* We do define a different macro for each case; then if we want to have
     * separate mutexes for some of them, the only changes needed are here.
@@ -7164,24 +7207,24 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect.
 #  if defined(HAS_LOCALECONV) && (  ! defined(USE_POSIX_2008_LOCALE)        \
                                  || ! defined(HAS_LOCALECONV_L)             \
                                  ||   defined(TS_W32_BROKEN_LOCALECONV))
-#    define LOCALECONV_LOCK   LOCALE_LOCK_
+#    define LOCALECONV_LOCK   LOCALE_LOCK_(0)
 #    define LOCALECONV_UNLOCK LOCALE_UNLOCK_
 #  endif
 #  if defined(HAS_NL_LANGINFO) && (   ! defined(HAS_THREAD_SAFE_NL_LANGINFO_L) \
                                    || ! defined(USE_POSIX_2008_LOCALE))
-#    define NL_LANGINFO_LOCK   LOCALE_LOCK_
+#    define NL_LANGINFO_LOCK   LOCALE_LOCK_(0)
 #    define NL_LANGINFO_UNLOCK LOCALE_UNLOCK_
 #  endif
 #  if defined(HAS_MBLEN) && ! defined(HAS_MBRLEN)
-#    define MBLEN_LOCK_   LOCALE_LOCK_
+#    define MBLEN_LOCK_   LOCALE_LOCK_(0)
 #    define MBLEN_UNLOCK_ LOCALE_UNLOCK_
 #  endif
 #  if defined(HAS_MBTOWC) && ! defined(HAS_MBRTOWC)
-#    define MBTOWC_LOCK_   LOCALE_LOCK_
+#    define MBTOWC_LOCK_   LOCALE_LOCK_(0)
 #    define MBTOWC_UNLOCK_ LOCALE_UNLOCK_
 #  endif
 #  if defined(HAS_WCTOMB) && ! defined(HAS_WCRTOMB)
-#    define WCTOMB_LOCK_   LOCALE_LOCK_
+#    define WCTOMB_LOCK_   LOCALE_LOCK_(0)
 #    define WCTOMB_UNLOCK_ LOCALE_UNLOCK_
 #  endif
 #  if defined(USE_THREAD_SAFE_LOCALE)
@@ -7198,7 +7241,7 @@ the plain locale pragma without a parameter (S<C<use locale>>) is in effect.
 #    define SETLOCALE_LOCK    NOOP
 #    define SETLOCALE_UNLOCK  NOOP
 #  else
-#    define SETLOCALE_LOCK   LOCALE_LOCK_
+#    define SETLOCALE_LOCK   LOCALE_LOCK_(0)
 #    define SETLOCALE_UNLOCK LOCALE_UNLOCK_
 
     /* On platforms without per-thread locales, when another thread can switch
diff --git a/sv.c b/sv.c
index 5636551575..de6dc8070f 100644
--- a/sv.c
+++ b/sv.c
@@ -15600,6 +15600,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
 
     /* Did the locale setup indicate UTF-8? */
     PL_utf8locale	= proto_perl->Iutf8locale;
+
+#ifdef USE_LOCALE_THREADS
+    assert(PL_locale_mutex_depth <= 0);
+    PL_locale_mutex_depth = 0;
+#endif
 #if defined(USE_ITHREADS) && ! defined(USE_THREAD_SAFE_LOCALE)
     PL_lc_numeric_mutex_depth = 0;
 #endif