"op-entry" DTrace probe

6 files changed, 73 insertions, 2 deletions

diff --git a/dump.c b/dump.c
index 0733b30841..ada6ae9372 100644
--- a/dump.c
+++ b/dump.c
@@ -2129,6 +2129,8 @@ Perl_runops_debug(pTHX)
 	    if (DEBUG_t_TEST_) debop(PL_op);
 	    if (DEBUG_P_TEST_) debprof(PL_op);
 	}
+
+        OP_ENTRY_PROBE(OP_NAME(PL_op));
     } while ((PL_op = PL_op->op_ppaddr(aTHX)));
     DEBUG_l(Perl_deb(aTHX_ "leaving RUNOPS level\n"));
 
diff --git a/mydtrace.h b/mydtrace.h
index 1c969ee604..8ee130f609 100644
--- a/mydtrace.h
+++ b/mydtrace.h
@@ -32,6 +32,12 @@
 	PERL_SUB_RETURN(tmp_func, file, line, stash);	\
     }
 
+#    define OP_ENTRY_PROBE(name)                        \
+    if (PERL_OP_ENTRY_ENABLED()) {    		        \
+	const char *tmp_name = name;			\
+	PERL_OP_ENTRY(tmp_name, file, line, stash);	\
+    }
+
 #  else
 
 #    define ENTRY_PROBE(func, file, line, stash) 	\
@@ -44,6 +50,11 @@
 	PERL_SUB_RETURN(func, file, line, stash); 	\
     }
 
+#    define OP_ENTRY_PROBE(name)	                \
+    if (PERL_OP_ENTRY_ENABLED()) {    		        \
+	PERL_OP_ENTRY(name); 	                        \
+    }
+
 #  endif
 
 #  define PHASE_CHANGE_PROBE(new_phase, old_phase)      \
@@ -57,6 +68,7 @@
 #  define ENTRY_PROBE(func, file, line, stash)
 #  define RETURN_PROBE(func, file, line, stash)
 #  define PHASE_CHANGE_PROBE(new_phase, old_phase)
+#  define OP_ENTRY_PROBE(name)
 
 #endif
 
diff --git a/perldtrace.d b/perldtrace.d
index 8c051f6c86..f352b3103c 100644
--- a/perldtrace.d
+++ b/perldtrace.d
@@ -8,6 +8,8 @@ provider perl {
     probe sub__return(const char *, const char *, int, const char *);
 
     probe phase__change(const char *, const char *);
+
+    probe op__entry(const char *);
 };
 
 /*
diff --git a/pod/perldtrace.pod b/pod/perldtrace.pod
index 39551e1749..60a93705a4 100644
--- a/pod/perldtrace.pod
+++ b/pod/perldtrace.pod
@@ -55,6 +55,10 @@ package name of the function.
 
 The C<phase-change> probe was added.
 
+=item 5.18.0
+
+The C<op-entry> probe was added.
+
 =back
 
 =head1 PROBES
@@ -97,6 +101,17 @@ C<${^GLOBAL_PHASE}> reports.
             copyinstr(arg1), copyinstr(arg0));
     }
 
+=item op-entry(OPNAME)
+
+Traces the execution of each opcode in the Perl runloop. This probe
+is fired before the opcode is executed. When the Perl debugger is
+enabled, the DTrace probe is fired I<after> the debugger hooks (but
+still before the opcode itself is executed).
+
+    :*perl*::op-entry {
+        printf("About to execute opcode %s\n", copyinstr(arg0));
+    }
+
 =back
 
 =head1 EXAMPLES
@@ -156,6 +171,14 @@ C<${^GLOBAL_PHASE}> reports.
     read                                                            374
     stat64                                                         1056
 
+=item Perl functions that execute the most opcodes
+
+    # dtrace -qZn 'sub-entry { self->fqn = strjoin(copyinstr(arg3), strjoin("::", copyinstr(arg0))) } op-entry /self->fqn != ""/ { @[self->fqn] = count() } END { trunc(@, 3) }'
+
+    warnings::unimport                                             4589
+    Exporter::Heavy::_rebuild_cache                                5039
+    Exporter::import                                              14578
+
 =back
 
 =head1 REFERENCES
@@ -172,6 +195,16 @@ L<http://www.amazon.com/DTrace-Dynamic-Tracing-Solaris-FreeBSD/dp/0132091518/>
 
 =back
 
+=head1 SEE ALSO
+
+=over 4
+
+=item L<Devel::DTrace::Provider>
+
+This CPAN module lets you create application-level DTrace probes written in Perl.
+
+=back
+
 =head1 AUTHORS
 
 Shawn M Moore C<sartak@gmail.com>
diff --git a/run.c b/run.c
index 8c2622a277..01b5f069f9 100644
--- a/run.c
+++ b/run.c
@@ -38,7 +38,9 @@ Perl_runops_standard(pTHX)
 {
     dVAR;
     OP *op = PL_op;
+    OP_ENTRY_PROBE(OP_NAME(op));
     while ((PL_op = op = op->op_ppaddr(aTHX))) {
+        OP_ENTRY_PROBE(OP_NAME(op));
     }
 
     TAINT_NOT;
diff --git a/t/run/dtrace.t b/t/run/dtrace.t
index 625e403907..183868d5d3 100644
--- a/t/run/dtrace.t
+++ b/t/run/dtrace.t
@@ -24,7 +24,7 @@ use strict;
 use warnings;
 use IPC::Open2;
 
-plan(tests => 5);
+plan(tests => 7);
 
 dtrace_like(
     '1',
@@ -117,6 +117,21 @@ PHASES
      'make sure sub-entry and phase-change interact well',
 );
 
+dtrace_like(<< 'PERL_SCRIPT',
+    my $tmp = "foo";
+    $tmp =~ s/f/b/;
+    chop $tmp;
+PERL_SCRIPT
+    << 'D_SCRIPT',
+    op-entry { printf("op-entry <%s>\n", copyinstr(arg0)) }
+D_SCRIPT
+    [
+        qr/op-entry <subst>/,
+        qr/op-entry <schop>/,
+    ],
+    'basic op probe',
+);
+
 sub dtrace_like {
     my $perl     = shift;
     my $probes   = shift;
@@ -152,6 +167,11 @@ sub dtrace_like {
     die "Unexpected error from DTrace: $result"
         if $child_exit_status != 0;
 
-    like($result, $expected, $name);
+    if (ref($expected) eq 'ARRAY') {
+        like($result, $_, $name) for @$expected;
+    }
+    else {
+        like($result, $expected, $name);
+    }
 }