[patch] log the interpreter id in warnings

Message-ID: <40847869.1000906@stason.org>

p4raw-id: //depot/perl@22721

diff --git a/gv.c b/gv.c
index 8a27065..68328ac 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1246,7 +1246,8 @@ Perl_gp_free(pTHX_ GV *gv)
     if (gp->gp_refcnt == 0) {
        if (ckWARN_d(WARN_INTERNAL))
            Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                       "Attempt to free unreferenced glob pointers");
+                       "Attempt to free unreferenced glob pointers"
+                        pTHX__FORMAT pTHX__VALUE);
         return;
     }
     if (gp->gp_cv) {

diff --git a/handy.h b/handy.h
index b88c729..19a5934 100644 (file)
--- a/handy.h
+++ b/handy.h
@@ -665,3 +665,19 @@ hopefully catches attempts to access uninitialized memory.
 # endif
 #endif
 
+/* convenience debug macros */
+#ifdef USE_ITHREADS
+#define pTHX_FORMAT  "Perl interpreter: 0x%p"
+#define pTHX__FORMAT ", Perl interpreter: 0x%p"
+#define pTHX_VALUE_   (unsigned long)my_perl,
+#define pTHX_VALUE    (unsigned long)my_perl
+#define pTHX__VALUE_ ,(unsigned long)my_perl,
+#define pTHX__VALUE  ,(unsigned long)my_perl
+#else
+#define pTHX_FORMAT 
+#define pTHX__FORMAT
+#define pTHX_VALUE_ 
+#define pTHX_VALUE
+#define pTHX__VALUE_ 
+#define pTHX__VALUE
+#endif /* USE_ITHREADS */

diff --git a/hv.c b/hv.c
index 627140b..ca945f6 100644 (file)
--- a/hv.c
+++ b/hv.c
@@ -2016,9 +2016,10 @@ S_unshare_hek_or_pvn(pTHX_ HEK *hek, const char *str, I32 len, U32 hash)
     UNLOCK_STRTAB_MUTEX;
     if (!found && ckWARN_d(WARN_INTERNAL))
        Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                    "Attempt to free non-existent shared string '%s'%s",
+                    "Attempt to free non-existent shared string '%s'%s"
+                    pTHX__FORMAT,
                     hek ? HEK_KEY(hek) : str,
-                    (k_flags & HVhek_UTF8) ? " (utf8)" : "");
+                    ((k_flags & HVhek_UTF8) ? " (utf8)" : "") pTHX__VALUE);
     if (k_flags & HVhek_FREEKEY)
        Safefree(str);
 }

diff --git a/perl.c b/perl.c
index a769190..63438e8 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -847,7 +847,9 @@ perl_destruct(pTHXx)
            svend = &sva[SvREFCNT(sva)];
            for (sv = sva + 1; sv < svend; ++sv) {
                if (SvTYPE(sv) != SVTYPEMASK) {
-                   PerlIO_printf(Perl_debug_log, "leaked: 0x%p\n", sv);
+                   PerlIO_printf(Perl_debug_log, "leaked: 0x%p"
+                                  pTHX__FORMAT "\n",
+                                  sv pTHX__VALUE);
                }
            }
        }

diff --git a/sv.c b/sv.c
index 36fbc21..c4aa66c 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -246,8 +246,8 @@ S_del_sv(pTHX_ SV *p)
        if (!ok) {
            if (ckWARN_d(WARN_INTERNAL))        
                Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                           "Attempt to free non-arena SV: 0x%"UVxf,
-                           PTR2UV(p));
+                           "Attempt to free non-arena SV: 0x%"UVxf
+                            pTHX__FORMAT, PTR2UV(p) pTHX__VALUE);
            return;
        }
     }
@@ -5654,8 +5654,8 @@ Perl_sv_free(pTHX_ SV *sv)
        }
        if (ckWARN_d(WARN_INTERNAL))
            Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
-                        "Attempt to free unreferenced scalar: SV 0x%"UVxf,
-                PTR2UV(sv));
+                        "Attempt to free unreferenced scalar: SV 0x%"UVxf
+                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
        return;
     }
     if (--(SvREFCNT(sv)) > 0)
@@ -5670,8 +5670,8 @@ Perl_sv_free2(pTHX_ SV *sv)
     if (SvTEMP(sv)) {
        if (ckWARN_d(WARN_DEBUGGING))
            Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
-                       "Attempt to free temp prematurely: SV 0x%"UVxf,
-                       PTR2UV(sv));
+                       "Attempt to free temp prematurely: SV 0x%"UVxf
+                        pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
        return;
     }
 #endif