[perl #80548] Add the stash name to DTrace probes

This adds an additional parameter to perl's dtrace probes with the stash
name of the subroutine. This generally looks nicer than the filename but
gives a similar level of context.

As this is an additional parameter this will not have an impact on
existing DTrace scripts. (Also due to the way DTrace works I believe it
does not break binary compatibility and would be safe to backport to
maint-5.12 if desired, but I'm not a DTrace expert.)

diff --git a/cop.h b/cop.h
index 0a6169b..939d1ff 100644 (file)
--- a/cop.h
+++ b/cop.h
@@ -617,7 +617,8 @@ struct block_format {
 #define PUSHSUB_BASE(cx)                                               \
        ENTRY_PROBE(GvENAME(CvGV(cv)),                                  \
                CopFILE((const COP *)CvSTART(cv)),                      \
 #define PUSHSUB_BASE(cx)                                               \
        ENTRY_PROBE(GvENAME(CvGV(cv)),                                  \
                CopFILE((const COP *)CvSTART(cv)),                      \

-               CopLINE((const COP *)CvSTART(cv)));                     \
+               CopLINE((const COP *)CvSTART(cv)),                      \
+               CopSTASHPV((const COP *)CvSTART(cv)));                  \

                                                                        \
        cx->blk_sub.cv = cv;                                            \
        cx->blk_sub.olddepth = CvDEPTH(cv);                             \
                                                                        \
        cx->blk_sub.cv = cv;                                            \
        cx->blk_sub.olddepth = CvDEPTH(cv);                             \


@@ -667,7 +668,8 @@ struct block_format {
     STMT_START {                                                       \
        RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)),          \
                CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)),      \
     STMT_START {                                                       \
        RETURN_PROBE(GvENAME(CvGV((const CV*)cx->blk_sub.cv)),          \
                CopFILE((COP*)CvSTART((const CV*)cx->blk_sub.cv)),      \

-               CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)));     \
+               CopLINE((COP*)CvSTART((const CV*)cx->blk_sub.cv)),      \
+               CopSTASHPV((COP*)CvSTART((const CV*)cx->blk_sub.cv)));  \

                                                                        \
        if (CxHASARGS(cx)) {                                            \
            POP_SAVEARRAY();                                            \
                                                                        \
        if (CxHASARGS(cx)) {                                            \
            POP_SAVEARRAY();                                            \

diff --git a/mydtrace.h b/mydtrace.h
index daabcfa..75e6918 100644 (file)
--- a/mydtrace.h
+++ b/mydtrace.h
@@ -13,21 +13,21 @@
 
 #  include "perldtrace.h"
 
 
 #  include "perldtrace.h"
 

-#  define ENTRY_PROBE(func, file, line)        \
-    if (PERL_SUB_ENTRY_ENABLED()) {            \
-       PERL_SUB_ENTRY(func, file, line);       \
+#  define ENTRY_PROBE(func, file, line, stash)         \
+    if (PERL_SUB_ENTRY_ENABLED()) {                    \
+       PERL_SUB_ENTRY(func, file, line, stash);        \

     }
 
     }
 

-#  define RETURN_PROBE(func, file, line)       \
-    if (PERL_SUB_RETURN_ENABLED()) {           \
-       PERL_SUB_RETURN(func, file, line);      \
+#  define RETURN_PROBE(func, file, line, stash)        \
+    if (PERL_SUB_RETURN_ENABLED()) {                   \
+       PERL_SUB_RETURN(func, file, line, stash);       \

     }
 
 #else
 
 /* NOPs */
     }
 
 #else
 
 /* NOPs */

-#  define ENTRY_PROBE(func, file, line)
-#  define RETURN_PROBE(func, file, line)
+#  define ENTRY_PROBE(func, file, line, stash)
+#  define RETURN_PROBE(func, file, line, stash)

 
 #endif
 
 
 #endif
 

diff --git a/perldtrace.d b/perldtrace.d
index c5844ea..5175f24 100644 (file)
--- a/perldtrace.d
+++ b/perldtrace.d
@@ -4,8 +4,8 @@
  */
 
 provider perl {
  */
 
 provider perl {

-    probe sub__entry(char *, char *, int);
-    probe sub__return(char *, char *, int);
+    probe sub__entry(char *, char *, int, char *);
+    probe sub__return(char *, char *, int, char *);

 };
 
 /*
 };
 
 /*