diff options
| -rw-r--r-- | dump.c | 2 | ||||
| -rw-r--r-- | mydtrace.h | 12 | ||||
| -rw-r--r-- | perldtrace.d | 2 | ||||
| -rw-r--r-- | pod/perldtrace.pod | 33 | ||||
| -rw-r--r-- | run.c | 2 | ||||
| -rw-r--r-- | t/run/dtrace.t | 24 |
6 files changed, 73 insertions, 2 deletions
@@ -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> @@ -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); + } } |