@@ -1,11 +1,22 @@
# /
+FileHandle.c
+FileHandle.o
MANIFEST.bak
MYMETA.json
MYMETA.yml
Makefile
Makefile.old
+NYTProf.bs
+NYTProf.c
+NYTProf.o
blib/
-# /t/
+*.tar.gz
+*.o
+*.c
+*.bs
+*.out
+.*.swp
+nytprof-50-errno.out
/t/*.new
/t/*.newp
/t/*.out
@@ -14,3 +25,4 @@ blib/
/t/nytprof_test30-fork-*.out.*
/t/*_outdir
/t/auto
+pm_to_blib
@@ -1,13 +1,85 @@
=head1 NAME
-Changes - List of significant changes to Devel::NYTProf
+Changes - History of significant changes in Devel::NYTProf
=cut
-TODO: study http://www.postgresql.org/docs/9.2/static/pgtesttiming.html
-and reference in our docs.
+=head2 Changes in Devel::NYTProf 5.06 - 12th Sept 2013
-http://stackoverflow.com/questions/4132270/how-to-ignore-some-subroutine-calls-in-nytprof-reporting/14085984#14085984
+ Fixed for perl 5.19.4. RT#88288 thanks to sprout.
+ Fixed test for change in perl 5.18.x error message text.
+ Fixed to no longer open a file when start=no. RT#86497/RT#87404.
+ Fixed compiler warnings. RT#86728 thanks to Alexander Bluhm.
+
+ Document that Devel::NYTProf needs to be loaded as early as possible
+ even when using start=no. PR#10 thanks to moritz.
+ Removed unused keyword $Id$. PR#9 thanks to dsteinbrunner.
+ Removed old benchmark.pl files. RT#86704.
+ Corrected assorted typos. PR#8 thanks to dsteinbrunner.
+ Added meta-spec to META_MERGE. PR#12 thanks to dsteinbrunner.
+
+=head2 Changes in Devel::NYTProf 5.05 - 2nd July 2013
+
+ Fixed crash on "Can't use string as a subroutine ref" error,
+ and probably other die-at-pp_entersub cases,
+ with thanks to Zefram. RT#86638
+ Fixed crash with libcexit=1, thanks to Zefram. RT#86548
+
+=head2 Changes in Devel::NYTProf 5.04 - 20th June 2013
+
+ Allow negative times in tests for systems with unstable clocks
+ thanks to Gisle Aas, RT#85556.
+ Added libcexit=1 option thanks to Zefram, RT#75912.
+ Added documentation for endatexit and libcexit options.
+ Added documentation for nytprofhtml --minimal
+ thanks to Mike Doherty, RT#86039.
+
+=head2 Changes in Devel::NYTProf 5.03 - 20th May 2013
+
+ Fix windows to use flamegraph.bat [Christian Walde]
+ Generates META.yml which mentions github repo [Christian Walde]
+ Add meta robots noindex to html pages [Tokuhiro Matsuno]
+
+=head2 Changes in Devel::NYTProf 5.02 - 21st April 2013
+
+ Fix Windows build, properly RT#84738.
+
+=head2 Changes in Devel::NYTProf 5.01 - 19th April 2013
+
+ Fix Windows build RT#84738.
+
+ Can't rely on #!-line to always work, PR#3
+ thanks to Gisle Aas.
+
+ Avoid triggering "gcc internal compiler error" PR#4
+ thanks to Gisle Aas.
+
+=head2 Changes in Devel::NYTProf 5.00 - 8th April 2013
+
+ Added subroutine entry and return event stream,
+ controlled via the calls=N option. Default calls=1.
+
+ Added nytprofcalls command to process the call event stream to
+ generate timings for distinct call stacks (experimental).
+
+ Added Flame Graph visualization SVG using the call stack data.
+
+ Changed blocks=N option to be 0 (disabled) by default.
+
+ Fixed test for perl 5.17+ hash randomization.
+ Fixed nytprofhtml for Windows thanks to Jan Dubois. PR#2
+ Fixed assorted nits thanks to Steve Peters. PR#1
+ Deprecated nytprofcsv - speak up if you use it!
+ No longer warn about $&, $` and $' being slow if $] >= 5.017008.
+
+=head2 Changes in Devel::NYTProf 4.25 - 6th Feb 2013
+
+ Fix u2time clock (ie Time::HiRes, used by Windows)
+
+=head2 Changes in Devel::NYTProf 4.24 - 3rd Feb 2013
+
+ Clarify sigexit option docs.
+ Loosen test timing constraints (for slow cpantester VMs).
=head2 Changes in Devel::NYTProf 4.23 - 31st Dec 2012
@@ -12,8 +12,6 @@
* Steve Peters, steve at fisharerojo.org
*
* ************************************************************************
- * $Id$
- * ************************************************************************
*/
/* Arguably this header is naughty, as it's not self contained, because it
@@ -45,6 +43,7 @@ const char *NYTP_type_of_offset(NYTP_file file);
#define NYTP_TAG_NO_TAG '\0' /* Used as a flag to mean "no tag" */
#define NYTP_TAG_ATTRIBUTE ':' /* :name=value\n */
+#define NYTP_TAG_OPTION '!' /* !name=value\n */
#define NYTP_TAG_COMMENT '#' /* till newline */
#define NYTP_TAG_TIME_BLOCK '*'
#define NYTP_TAG_TIME_LINE '+'
@@ -58,12 +57,15 @@ const char *NYTP_type_of_offset(NYTP_file file);
#define NYTP_TAG_STRING '\''
#define NYTP_TAG_STRING_UTF8 '"'
#define NYTP_TAG_START_DEFLATE 'z'
+#define NYTP_TAG_SUB_ENTRY '>'
+#define NYTP_TAG_SUB_RETURN '<'
/* also add new items to nytp_tax_index below */
-typedef enum {
+typedef enum { /* XXX keep in sync with various *_callback strucures */
nytp_no_tag,
nytp_version, /* Not actually a tag, but needed by the perl callback */
nytp_attribute,
+ nytp_option,
nytp_comment,
nytp_time_block,
nytp_time_line,
@@ -77,7 +79,9 @@ typedef enum {
nytp_string,
nytp_string_utf8,
nytp_start_deflate,
- nytp_tag_max
+ nytp_sub_entry,
+ nytp_sub_return,
+ nytp_tag_max /* keep last */
} nytp_tax_index;
void NYTProf_croak_if_not_stdio(NYTP_file file, const char *function);
@@ -93,6 +97,9 @@ size_t NYTP_write_attribute_unsigned(NYTP_file ofile, const char *key,
size_t key_len, unsigned long value);
size_t NYTP_write_attribute_nv(NYTP_file ofile, const char *key,
size_t key_len, NV value);
+size_t NYTP_write_option_pv(NYTP_file ofile, const char *key,
+ const char *value, size_t value_len);
+size_t NYTP_write_option_iv(NYTP_file ofile, const char *key, IV value);
size_t NYTP_start_deflate_write_tag_comment(NYTP_file ofile, int compression_level);
size_t NYTP_write_process_start(NYTP_file ofile, U32 pid, U32 ppid, NV time_of_day);
size_t NYTP_write_process_end(NYTP_file ofile, U32 pid, NV time_of_day);
@@ -113,6 +120,9 @@ size_t NYTP_write_sub_callers(NYTP_file ofile, U32 fid, U32 line,
size_t NYTP_write_src_line(NYTP_file ofile, U32 fid,
U32 line, const char *text, I32 text_len);
size_t NYTP_write_discount(NYTP_file ofile);
+size_t NYTP_write_call_entry(NYTP_file ofile, U32 caller_fid, U32 caller_line);
+size_t NYTP_write_call_return(NYTP_file ofile, U32 prof_depth, const char *called_subname_pv,
+ NV incl_subr_ticks, NV excl_subr_ticks);
/* XXX
@@ -738,7 +738,7 @@ read_u32(NYTP_file ifile)
newint = d & 0xF;
length = 3;
}
- else if (d == 0xFF) { /* = 32 bits */
+ else { /* d == 0xFF */ /* = 32 bits */
newint = 0;
length = 4;
}
@@ -846,15 +846,15 @@ NYTP_write_comment(NYTP_file ofile, const char *format, ...) {
return retval + 2;
}
-size_t
-NYTP_write_attribute_string(NYTP_file ofile,
+static size_t
+NYTP_write_plain_kv(NYTP_file ofile, const char prefix,
const char *key, size_t key_len,
const char *value, size_t value_len)
{
size_t total;
size_t retval;
- total = retval = NYTP_write(ofile, ":", 1);
+ total = retval = NYTP_write(ofile, &prefix, 1);
if (retval != 1)
return retval;
@@ -877,6 +877,14 @@ NYTP_write_attribute_string(NYTP_file ofile,
return total;
}
+size_t
+NYTP_write_attribute_string(NYTP_file ofile,
+ const char *key, size_t key_len,
+ const char *value, size_t value_len)
+{
+ return NYTP_write_plain_kv(ofile, ':', key, key_len, value, value_len);
+}
+
#ifndef CHAR_BIT
# define CHAR_BIT 8
#endif
@@ -914,6 +922,28 @@ NYTP_write_attribute_nv(NYTP_file ofile, const char *key,
return NYTP_write_attribute_string(ofile, key, key_len, buffer, len);
}
+/* options */
+
+size_t
+NYTP_write_option_pv(NYTP_file ofile,
+ const char *key,
+ const char *value, size_t value_len)
+{
+ return NYTP_write_plain_kv(ofile, '!', key, strlen(key), value, value_len);
+}
+
+size_t
+NYTP_write_option_iv(NYTP_file ofile, const char *key, IV value)
+{
+ /* 3: 1 for rounding errors, 1 for the sign, 1 for the '\0' */
+ char buffer[(int)(sizeof (IV) * CHAR_BIT * LOG_2_OVER_LOG_10 + 3)];
+ const size_t len = my_snprintf(buffer, sizeof(buffer), "%ld", value);
+
+ return NYTP_write_option_pv(ofile, key, buffer, len);
+}
+
+/* other */
+
#ifdef HAS_ZLIB
size_t
@@ -1093,6 +1123,53 @@ NYTP_write_time_line(NYTP_file ofile, I32 elapsed, U32 overflow,
return write_time_common(ofile, NYTP_TAG_TIME_LINE, elapsed, overflow, fid, line);
}
+
+size_t
+NYTP_write_call_entry(NYTP_file ofile, U32 caller_fid, U32 caller_line)
+{
+ size_t total;
+ size_t retval;
+
+ total = retval = output_tag_u32(ofile, NYTP_TAG_SUB_ENTRY, caller_fid);
+ if (retval < 1)
+ return retval;
+
+ total += retval = output_u32(ofile, caller_line);
+ if (retval < 1)
+ return retval;
+
+ return total;
+}
+
+size_t
+NYTP_write_call_return(NYTP_file ofile, U32 prof_depth, const char *called_subname_pv,
+ NV incl_subr_ticks, NV excl_subr_ticks)
+{
+ size_t total;
+ size_t retval;
+
+ total = retval = output_tag_u32(ofile, NYTP_TAG_SUB_RETURN, prof_depth);
+ if (retval < 1)
+ return retval;
+
+ total += retval = output_nv(ofile, incl_subr_ticks);
+ if (retval < 1)
+ return retval;
+
+ total += retval = output_nv(ofile, excl_subr_ticks);
+ if (retval < 1)
+ return retval;
+
+ if (!called_subname_pv)
+ called_subname_pv = "(null)";
+ total += retval = output_str(ofile, called_subname_pv, strlen(called_subname_pv));
+ if (retval < 1)
+ return retval;
+
+ return total;
+}
+
+
size_t
NYTP_write_sub_info(NYTP_file ofile, U32 fid,
const char *name, I32 len,
@@ -1289,6 +1366,21 @@ SV *value
RETVAL
size_t
+NYTP_write_option(handle, key, value)
+NYTP_file handle
+SV *key
+SV *value
+ PREINIT:
+ STRLEN key_len;
+ const char *const key_p = SvPVbyte(key, key_len);
+ STRLEN value_len;
+ const char *const value_p = SvPVbyte(value, value_len);
+ CODE:
+ RETVAL = NYTP_write_option_pv(handle, key_p, value_p, value_len);
+ OUTPUT:
+ RETVAL
+
+size_t
NYTP_write_process_start(handle, pid, ppid, time_of_day)
NYTP_file handle
U32 pid
@@ -1340,6 +1432,20 @@ U32 fid
U32 line
size_t
+NYTP_write_call_entry(handle, caller_fid, caller_line)
+NYTP_file handle
+U32 caller_fid
+U32 caller_line
+
+size_t
+NYTP_write_call_return(handle, prof_depth, called_subname_pv, incl_subr_ticks, excl_subr_ticks)
+NYTP_file handle
+U32 prof_depth
+const char *called_subname_pv
+NV incl_subr_ticks
+NV excl_subr_ticks
+
+size_t
NYTP_write_sub_info(handle, fid, name, first_line, last_line)
NYTP_file handle
U32 fid
@@ -1,5 +1,4 @@
# vim: ts=8 sw=2 sts=0 noexpandtab:
-# $Id$
HACKING Devel::NYTProf
======================
@@ -357,11 +356,22 @@ We need a start=runtime option to start at the _end_ of any INIT subs.
(The current start=init option is the closest we have but it's not very
useful if lots of other work is done in INIT blocks.)
-We need an option to discount the time spent in CORE:accept so that time
-pure-perl webservers spend waiting for the next request doesn't distort the
-profile. Possibly straight-forward to implement. The trick is to add the time
-spent in the sub to the statement profiler overhead time, thus getting it
-subtracted from the higher level sub time. Maybe.
+We need an option to discount the time spent in specific subs, like we do for
+CORE:accept so that time pure-perl webservers spend waiting for the next
+request doesn't distort the profile. Probably just needs a hash lookup.
+http://stackoverflow.com/questions/4132270/how-to-ignore-some-subroutine-calls-in-nytprof-reporting/14085984#14085984
+
+Remove nytprofcsv
+
+Add "goto skip_sub_profile;" to this?: (and/or figure out why already_counted++ isn't enough)
+ /* catch profile_subs being turned off by disable_profile call */
+ if (!profile_subs)
+ subr_entry->already_counted++;
+
+study http://www.postgresql.org/docs/9.2/static/pgtesttiming.html
+See pg contrib/pg_test_timing/pg_test_timing.c
+
+Show /sys/devices/system/clocksource/clocksource0/available_clocksource
+and /sys/devices/system/clocksource/clocksource0/current_clocksource
+in the Makefile.PL and test output, if present
-Generate Flame Graphs from the subroutine profiler data:
-http://dtrace.org/blogs/brendan/2011/12/16/flame-graphs/
@@ -1,5 +1,4 @@
# vim: ts=8 sw=2 sts=0 noexpandtab:
-# $Id$
Devel::NYTProf Installation Notes
=================================
@@ -2,24 +2,30 @@
.gitignore
.indent.pro
.perltidyrc
-benchmark.pl
+Changes
+FileHandle.h
+FileHandle.xs
+HACKING
+INSTALL
+MANIFEST This list of files
+Makefile.PL
+MemoryProfiling.pod
+NYTProf.h
+NYTProf.xs
+README.md
+bin/flamegraph.pl
+bin/nytprofcalls
bin/nytprofcg
bin/nytprofcsv
bin/nytprofhtml
bin/nytprofmerge
-Changes
demo/1m_stmts.pl
-demo/benchmark.pl
+demo/README
demo/closure.pl
demo/cpucache.pl
demo/demo-code.pl
demo/demo-run.pl
demo/exclusive-sub-time.pl
-demo/README
-FileHandle.h
-FileHandle.xs
-HACKING
-INSTALL
lib/Devel/NYTProf.pm
lib/Devel/NYTProf/Apache.pm
lib/Devel/NYTProf/Constants.pm
@@ -27,9 +33,17 @@ lib/Devel/NYTProf/Core.pm
lib/Devel/NYTProf/Data.pm
lib/Devel/NYTProf/FileHandle.pm
lib/Devel/NYTProf/FileInfo.pm
+lib/Devel/NYTProf/ReadStream.pm
+lib/Devel/NYTProf/Reader.pm
+lib/Devel/NYTProf/Run.pm
+lib/Devel/NYTProf/SubCallInfo.pm
+lib/Devel/NYTProf/SubInfo.pm
+lib/Devel/NYTProf/Test.pm
+lib/Devel/NYTProf/Util.pm
lib/Devel/NYTProf/js/asc.png
lib/Devel/NYTProf/js/bg.png
lib/Devel/NYTProf/js/desc.png
+lib/Devel/NYTProf/js/jit/Treemap.css
lib/Devel/NYTProf/js/jit/gradient-cushion1.png
lib/Devel/NYTProf/js/jit/gradient.png
lib/Devel/NYTProf/js/jit/gradient20.png
@@ -38,27 +52,10 @@ lib/Devel/NYTProf/js/jit/gradient40.png
lib/Devel/NYTProf/js/jit/gradient50.png
lib/Devel/NYTProf/js/jit/jit-yc.js
lib/Devel/NYTProf/js/jit/jit.js
-lib/Devel/NYTProf/js/jit/Treemap.css
lib/Devel/NYTProf/js/jquery-min.js
lib/Devel/NYTProf/js/jquery-tablesorter-min.js
lib/Devel/NYTProf/js/style-tablesorter.css
-lib/Devel/NYTProf/Reader.pm
-lib/Devel/NYTProf/ReadStream.pm
-lib/Devel/NYTProf/Run.pm
-lib/Devel/NYTProf/SubCallInfo.pm
-lib/Devel/NYTProf/SubInfo.pm
-lib/Devel/NYTProf/Test.pm
-lib/Devel/NYTProf/Util.pm
-Makefile
-Makefile.PL
-MANIFEST This list of files
-MemoryProfiling.pod
-MYMETA.json
-MYMETA.yml
-NYTProf.h
-NYTProf.xs
ppport.h
-README
slowops.h
t/00-load.t
t/10-run.t
@@ -79,51 +76,63 @@ t/90-pod.t
t/91-pod_coverage.t
t/92-file_port.t
t/lib/NYTProfTest.pm
+t/test01.calls
t/test01.p
t/test01.rdt
t/test01.t
t/test01.x
+t/test02.calls
t/test02.p
t/test02.rdt
t/test02.t
t/test02.x
+t/test03.calls
t/test03.p
t/test03.rdt
t/test03.t
t/test03.x
+t/test05.calls
t/test05.p
t/test05.rdt
t/test05.t
t/test05.x
+t/test06.calls
t/test06.p
t/test06.rdt
t/test06.t
t/test06.x
+t/test07.calls
t/test07.p
t/test07.rdt
t/test07.t
t/test07.x
+t/test08.calls
t/test08.p
t/test08.rdt
t/test08.t
t/test08.x
+t/test09.calls
t/test09.p
t/test09.rdt
t/test09.t
t/test09.x
+t/test10.calls
t/test10.p
t/test10.rdt
t/test10.t
t/test10.x
+t/test11.calls
t/test11.p
t/test11.rdt
t/test11.t
t/test11.x
+t/test12.calls
t/test12.p
t/test12.pl
t/test12.rdt
t/test12.t
t/test12.x
+t/test13.calls
t/test13.p
t/test13.rdt
t/test13.t
@@ -134,40 +143,50 @@ t/test14.pm_x
t/test14.rdt
t/test14.t
t/test14.x
+t/test16.calls
t/test16.p
t/test16.rdt
t/test16.t
t/test16.x
+t/test17-goto.calls
t/test17-goto.p
t/test17-goto.rdt
t/test17-goto.t
+t/test18-goto2.calls
t/test18-goto2.p
t/test18-goto2.pm
t/test18-goto2.t
+t/test20-streval.calls
t/test20-streval.p
t/test20-streval.rdt
t/test20-streval.t
t/test20-streval.x
+t/test21-streval3.calls
t/test21-streval3.p
t/test21-streval3.rdt
t/test21-streval3.t
t/test21-streval3.x
+t/test22-strevala.calls
t/test22-strevala.p
t/test22-strevala.rdt
t/test22-strevala.t
+t/test23-strevall.calls
t/test23-strevall.p
t/test23-strevall.rdt
t/test23-strevall.t
+t/test24-strevalc.calls
t/test24-strevalc.p
t/test24-strevalc.rdt
t/test24-strevalc.t
t/test25-strevalb.t
+t/test30-fork-0.calls
t/test30-fork-0.p
t/test30-fork-0.rdt
t/test30-fork-0.t
t/test30-fork-0.x
t/test30-fork-1.rdt
t/test30-fork-1.x
+t/test40pmc.calls
t/test40pmc.p
t/test40pmc.pm
t/test40pmc.pm_x
@@ -175,30 +194,38 @@ t/test40pmc.pmc
t/test40pmc.rdt
t/test40pmc.t
t/test40pmc.x
+t/test50-disable.calls
t/test50-disable.p
t/test50-disable.rdt
t/test50-disable.t
t/test50-disable.x
+t/test51-enable.calls
t/test51-enable.p
t/test51-enable.rdt
t/test51-enable.t
t/test51-enable.x
+t/test60-subname.calls
t/test60-subname.p
t/test60-subname.rdt
t/test60-subname.t
+t/test61-submerge.calls
t/test61-submerge.p
t/test61-submerge.rdt
t/test61-submerge.t
+t/test62-subcaller1.calls
t/test62-subcaller1.p
t/test62-subcaller1.rdt
t/test62-subcaller1.t
+t/test70-subexcl.calls
t/test70-subexcl.p
t/test70-subexcl.t
+t/test80-recurs.calls
t/test80-recurs.p
t/test80-recurs.rdt
t/test80-recurs.t
t/test81-swash.t
t/test82-version.t
+t/test90-strsubref.t
t/zzz.t
typemap
xt/61-cputime.t
@@ -209,4 +236,5 @@ xt/test45-overload.p
xt/test71-while.p
xt/test82-stress.t
xt/test90-stress.p
-META.yml Module meta-data (added by MakeMaker)
+META.yml Module YAML meta-data (added by MakeMaker)
+META.json Module JSON meta-data (added by MakeMaker)
@@ -0,0 +1,60 @@
+{
+ "abstract" : "Powerful fast feature-rich Perl source code profiler",
+ "author" : [
+ "Tim Bunce <timb@cpan.org>"
+ ],
+ "dynamic_config" : 1,
+ "generated_by" : "ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.131560",
+ "license" : [
+ "perl_5"
+ ],
+ "meta-spec" : {
+ "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec",
+ "version" : "2"
+ },
+ "name" : "Devel-NYTProf",
+ "no_index" : {
+ "directory" : [
+ "t",
+ "inc"
+ ],
+ "package" : [
+ "SVG"
+ ]
+ },
+ "prereqs" : {
+ "build" : {
+ "requires" : {
+ "ExtUtils::MakeMaker" : "0"
+ }
+ },
+ "runtime" : {
+ "requires" : {
+ "Getopt::Long" : "0",
+ "JSON::Any" : "0",
+ "List::Util" : "0",
+ "Test::Differences" : "0.60",
+ "Test::More" : "0.84",
+ "XSLoader" : "0"
+ }
+ }
+ },
+ "release_status" : "stable",
+ "resources" : {
+ "bugtracker" : {
+ "mailto" : "bug-devel-nytprof@rt.cpan.org",
+ "web" : "https://github.com/timbunce/devel-nytprof/issues"
+ },
+ "homepage" : "https://code.google.com/p/perl-devel-nytprof/",
+ "license" : [
+ "http://dev.perl.org/licenses/"
+ ],
+ "repository" : {
+ "type" : "git",
+ "url" : "git://github.com/timbunce/devel-nytprof.git",
+ "web" : "https://github.com/timbunce/devel-nytprof"
+ },
+ "x_MailingList" : "http://groups.google.com/group/develnytprof-dev"
+ },
+ "version" : "5.06"
+}
@@ -1,37 +1,33 @@
---- #YAML:1.0
-name: Devel-NYTProf
-version: 4.23
-abstract: Powerful fast feature-rich Perl source code profiler
+---
+abstract: 'Powerful fast feature-rich Perl source code profiler'
author:
- - Tim Bunce <timb@cpan.org>
-license: perl
-distribution_type: module
-configure_requires:
- ExtUtils::MakeMaker: 0
+ - 'Tim Bunce <timb@cpan.org>'
build_requires:
- ExtUtils::MakeMaker: 0
+ ExtUtils::MakeMaker: 0
+dynamic_config: 1
+generated_by: 'ExtUtils::MakeMaker version 6.68, CPAN::Meta::Converter version 2.131560'
+license: perl
+meta-spec:
+ url: http://module-build.sourceforge.net/META-spec-v1.4.html
+ version: 1.4
+name: Devel-NYTProf
+no_index:
+ directory:
+ - t
+ - inc
+ package:
+ - SVG
requires:
- Getopt::Long: 0
- JSON::Any: 0
- List::Util: 0
- Test::More: 0.84
- XSLoader: 0
+ Getopt::Long: 0
+ JSON::Any: 0
+ List::Util: 0
+ Test::Differences: 0.60
+ Test::More: 0.84
+ XSLoader: 0
resources:
- bugtracker:
- mailto: bug-devel-nytprof@rt.cpan.org
- web: https://github.com/timbunce/devel-nytprof/issues
- homepage: https://code.google.com/p/perl-devel-nytprof/
- license: http://dev.perl.org/licenses/
- MailingList: http://groups.google.com/group/develnytprof-dev
- repository:
- type: git
- url: git://github.com/timbunce/devel-nytprof.git
- web: https://github.com/timbunce/devel-nytprof
-no_index:
- directory:
- - t
- - inc
-generated_by: ExtUtils::MakeMaker version 6.56
-meta-spec:
- url: http://module-build.sourceforge.net/META-spec-v1.4.html
- version: 1.4
+ MailingList: http://groups.google.com/group/develnytprof-dev
+ bugtracker: https://github.com/timbunce/devel-nytprof/issues
+ homepage: https://code.google.com/p/perl-devel-nytprof/
+ license: http://dev.perl.org/licenses/
+ repository: git://github.com/timbunce/devel-nytprof.git
+version: 5.06
@@ -7,8 +7,6 @@
## http://search.cpan.org/dist/Devel-NYTProf/
##
###########################################################
-# $Id$
-###########################################################
use 5.008001;
use warnings;
@@ -32,6 +30,7 @@ if ($ENV{PERL_CORE}) {
'bin/nytprofhtml' => '$(INST_MAN1DIR)/nytprofhtml.1',
'bin/nytprofmerge'=> '$(INST_MAN1DIR)/nytprofmerge.1',
'bin/nytprofcsv' => '$(INST_MAN1DIR)/nytprofcsv.1',
+ 'bin/nytprofcalls'=> '$(INST_MAN1DIR)/nytprofcalls.1',
'bin/nytprofcg' => '$(INST_MAN1DIR)/nytprofcg.1',
} );
}
@@ -109,6 +108,10 @@ $mm_opts{CCFLAGS} = "-pg" if $opt_pg;
if( $ExtUtils::MakeMaker::VERSION >= 6.45 ) {
$mm_opts{META_MERGE} = {
+ "meta-spec" => { version => 2 },
+ no_index => {
+ package => [ 'SVG' ], # in bin/flamegraph.pl
+ },
resources => {
license => 'http://dev.perl.org/licenses/',
homepage => 'https://code.google.com/p/perl-devel-nytprof/',
@@ -151,13 +154,14 @@ WriteMakefile(
PREREQ_PM => {
'List::Util' => 0,
'Test::More' => '0.84',
+ 'Test::Differences' => '0.60',
'XSLoader' => 0,
'Getopt::Long' => 0,
'JSON::Any' => 0,
},
LIBS => [join ' ', @libs],
OBJECT => q/$(O_FILES)/,
- EXE_FILES => ['bin/nytprofhtml', 'bin/nytprofcsv', 'bin/nytprofcg', 'bin/nytprofmerge'],
+ EXE_FILES => ['bin/nytprofhtml', 'bin/flamegraph.pl', 'bin/nytprofcsv', 'bin/nytprofcalls', 'bin/nytprofcg', 'bin/nytprofmerge'],
@man,
INC => $INCLUDE,
clean => {
@@ -173,6 +177,11 @@ WriteMakefile(
COMPRESS => 'gzip -v9',
SUFFIX => 'gz',
},
+ META_MERGE => {
+ resources => {
+ repository => 'https://github.com/timbunce/devel-nytprof',
+ },
+ },
%mm_opts,
);
@@ -12,7 +12,5 @@
* Steve Peters, steve at fisharerojo.org
*
* ************************************************************************
- * $Id$
- * ************************************************************************
*/
@@ -13,8 +13,6 @@
* Steve Peters, steve at fisharerojo.org
*
* ************************************************************************
- * $Id$
- * ************************************************************************
*/
#ifndef WIN32
#define PERL_NO_GET_CONTEXT /* we want efficiency */
@@ -110,7 +108,7 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, cons
#define ZLIB_VERSION "0"
#endif
-#define NYTP_FILE_MAJOR_VERSION 4
+#define NYTP_FILE_MAJOR_VERSION 5
#define NYTP_FILE_MINOR_VERSION 0
#define NYTP_START_NO 0
@@ -180,40 +178,53 @@ Perl_gv_fetchfile_flags(pTHX_ const char *const name, const STRLEN namelen, cons
#define NYTP_SCi_CALLING_SUB 7 /* name of calling sub */
#define NYTP_SCi_elements 8 /* highest index, plus 1 */
-#define MAX_HASH_SIZE 512
-
-static unsigned int next_fid = 1; /* 0 is reserved */
/* we're not thread-safe (or even multiplicity safe) yet, so detect and bail */
#ifdef MULTIPLICITY
static PerlInterpreter *orig_my_perl;
#endif
-typedef struct hash_entry
-{
+
+#define MAX_HASH_SIZE 512
+
+typedef struct hash_entry Hash_entry;
+
+struct hash_entry {
unsigned int id;
- void* next_entry;
char* key;
- unsigned int key_len;
+ int key_len;
+ Hash_entry* next_entry;
+ Hash_entry* next_inserted; /* linked list in insertion order */
+};
+
+typedef struct hash_table {
+ Hash_entry** table;
+ char *name;
+ unsigned int size;
+ unsigned int entry_struct_size;
+ Hash_entry* first_inserted;
+ Hash_entry* prior_inserted; /* = last_inserted before the last insertion */
+ Hash_entry* last_inserted;
+ unsigned int next_id; /* starts at 1, 0 is reserved */
+} Hash_table;
+
+typedef struct {
+ Hash_entry he;
unsigned int eval_fid;
unsigned int eval_line_num;
unsigned int file_size;
unsigned int file_mtime;
unsigned int fid_flags;
char *key_abs;
- void* next_inserted; /* linked list in insertion order */
/* update autosplit logic in get_file_id if fields are added or changed */
-} Hash_entry;
+} fid_hash_entry;
-typedef struct hash_table
-{
- Hash_entry** table;
- unsigned int size;
- Hash_entry* first_inserted;
- Hash_entry* last_inserted;
-} Hash_table;
+static Hash_table fidhash = { NULL, "fid", MAX_HASH_SIZE, sizeof(fid_hash_entry), NULL, NULL, NULL, 1 };
-static Hash_table hashtable = { NULL, MAX_HASH_SIZE, NULL, NULL };
+typedef struct {
+ Hash_entry he;
+} str_hash_entry;
+static Hash_table strhash = { NULL, "str", MAX_HASH_SIZE, sizeof(str_hash_entry), NULL, NULL, NULL, 1 };
/* END Hash table definitions */
@@ -225,48 +236,64 @@ static char PROF_output_file[MAXPATHLEN+1] = "nytprof.out";
static unsigned int profile_opts = NYTP_OPTf_OPTIMIZE | NYTP_OPTf_SAVESRC;
static int profile_start = NYTP_START_BEGIN; /* when to start profiling */
-struct NYTP_int_options_t {
- const char *option_name;
- int option_value;
+struct NYTP_options_t {
+ const char *option_name;
+ IV option_iv;
+ char *option_pv; /* strdup'd */
};
/* XXX boolean options should be moved into profile_opts */
-static struct NYTP_int_options_t options[] = {
-#define profile_usecputime options[0].option_value
- { "usecputime", 0 },
-#define profile_subs options[1].option_value
- { "subs", 1 }, /* subroutine times */
-#define profile_blocks options[2].option_value
- { "blocks", 1 }, /* block and sub *exclusive* times */
-#define profile_leave options[3].option_value
- { "leave", 1 }, /* correct block end timing */
-#define embed_fid_line options[4].option_value
- { "expand", 0 },
-#define trace_level options[5].option_value
- { "trace", 0 },
-#define opt_use_db_sub options[6].option_value
- { "use_db_sub", 0 },
-#define compression_level options[7].option_value
- { "compress", default_compression_level },
-#define profile_clock options[8].option_value
- { "clock", -1 },
-#define profile_stmts options[9].option_value
- { "stmts", 1 }, /* statement exclusive times */
-#define profile_slowops options[10].option_value
- { "slowops", 2 }, /* slow opcodes, typically system calls */
-#define profile_findcaller options[11].option_value
- { "findcaller", 0 }, /* find sub caller instead of trusting outer */
-#define profile_forkdepth options[12].option_value
- { "forkdepth", -1 }, /* how many generations of kids to profile */
-#define opt_perldb options[13].option_value
- { "perldb", 0 }, /* force certain PL_perldb value */
-#define opt_nameevals options[14].option_value
- { "nameevals", 1 }, /* change $^P 0x100 bit */
-#define opt_nameanonsubs options[15].option_value
- { "nameanonsubs", 1 }, /* change $^P 0x200 bit */
-#define opt_evals options[16].option_value
- { "evals", 0 } /* handling of string evals - TBD XXX */
+static struct NYTP_options_t options[] = {
+#define profile_usecputime options[0].option_iv
+ { "usecputime", 0, NULL },
+#define profile_subs options[1].option_iv
+ { "subs", 1, NULL }, /* subroutine times */
+#define profile_blocks options[2].option_iv
+ { "blocks", 0, NULL }, /* block and sub *exclusive* times */
+#define profile_leave options[3].option_iv
+ { "leave", 1, NULL }, /* correct block end timing */
+#define embed_fid_line options[4].option_iv
+ { "expand", 0, NULL },
+#define trace_level options[5].option_iv
+ { "trace", 0, NULL },
+#define opt_use_db_sub options[6].option_iv
+ { "use_db_sub", 0, NULL },
+#define compression_level options[7].option_iv
+ { "compress", default_compression_level, NULL },
+#define profile_clock options[8].option_iv
+ { "clock", -1, NULL },
+#define profile_stmts options[9].option_iv
+ { "stmts", 1, NULL }, /* statement exclusive times */
+#define profile_slowops options[10].option_iv
+ { "slowops", 2, NULL }, /* slow opcodes, typically system calls */
+#define profile_findcaller options[11].option_iv
+ { "findcaller", 0, NULL }, /* find sub caller instead of trusting outer */
+#define profile_forkdepth options[12].option_iv
+ { "forkdepth", -1, NULL }, /* how many generations of kids to profile */
+#define opt_perldb options[13].option_iv
+ { "perldb", 0, NULL }, /* force certain PL_perldb value */
+#define opt_nameevals options[14].option_iv
+ { "nameevals", 1, NULL }, /* change $^P 0x100 bit */
+#define opt_nameanonsubs options[15].option_iv
+ { "nameanonsubs", 1, NULL }, /* change $^P 0x200 bit */
+#define opt_calls options[16].option_iv
+ { "calls", 1, NULL }, /* output call/return event stream */
+#define opt_evals options[17].option_iv
+ { "evals", 0, NULL } /* handling of string evals - TBD XXX */
};
+/* XXX TODO: add these to options:
+ if (strEQ(option, "file")) {
+ strncpy(PROF_output_file, value, MAXPATHLEN);
+ else if (strEQ(option, "log")) {
+ else if (strEQ(option, "start")) {
+ else if (strEQ(option, "addpid")) {
+ else if (strEQ(option, "optimize") || strEQ(option, "optimise")) {
+ else if (strEQ(option, "savesrc")) {
+ else if (strEQ(option, "endatexit")) {
+ else if (strEQ(option, "libcexit")) {
+and write the options to the stream when profiling starts.
+*/
+
/* time tracking */
@@ -319,9 +346,9 @@ static int (*u2time)(pTHX_ UV *) = 0;
typedef UV time_of_day_t[2];
# define TICKS_PER_SEC 1000000 /* 1 million */
# define get_time_of_day(into) (*u2time)(aTHX_ into)
-# define get_ticks_between(s, e, ticks, overflow) STMT_START { \
+# define get_ticks_between(typ, s, e, ticks, overflow) STMT_START { \
overflow = 0; \
- ticks = ((e[0] - s[0]) * TICKS_PER_SEC + e[1] - s[1]); \
+ ticks = ((e[0] - s[0]) * (typ)TICKS_PER_SEC + e[1] - s[1]); \
} STMT_END
#endif
@@ -346,7 +373,7 @@ static SV *DB_CHECK_cv;
static SV *DB_INIT_cv;
static SV *DB_END_cv;
static SV *DB_fin_cv;
-static char *class_mop_evaltag = " defined at ";
+static const char *class_mop_evaltag = " defined at ";
static int class_mop_evaltag_len = 12;
static unsigned int ticks_per_sec = 0; /* 0 forces error if not set */
@@ -362,6 +389,7 @@ static void set_option(pTHX_ const char*, const char*);
static int enable_profile(pTHX_ char *file);
static int disable_profile(pTHX);
static void finish_profile(pTHX);
+static void finish_profile_nocontext(void);
static void open_output_file(pTHX_ char *);
static int reinit_if_forked(pTHX);
static int parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *last_line_p, char *sub_name);
@@ -386,7 +414,7 @@ static HV *pkg_fids_hv; /* currently just package names */
#if (PERL_VERSION < 17) || ((PERL_VERSION == 17) && (PERL_SUBVERSION < 7)) || defined(PERL_SAWAMPERSAND)
static U8 last_sawampersand;
#define CHECK_SAWAMPERSAND(fid,line) STMT_START { \
- if ((U8)PL_sawampersand != last_sawampersand) { \
+ if (PL_sawampersand != last_sawampersand) { \
if (trace_level >= 1) \
logwarn("Slow regex match variable seen (0x%x->0x%x at %u:%u)\n", PL_sawampersand, last_sawampersand, fid, line); \
/* XXX this is a hack used by test14 to avoid different behaviour \
@@ -478,15 +506,27 @@ output_header(pTHX)
/* XXX add options, $0, etc, but beware of embedded newlines */
/* XXX would be good to adopt a proper charset & escaping for these */
- /* $^T */
- NYTP_write_attribute_unsigned(out, STR_WITH_LEN("basetime"), (unsigned long)PL_basetime);
- NYTP_write_attribute_string(out, STR_WITH_LEN("xs_version"), STR_WITH_LEN(XS_VERSION));
+ NYTP_write_attribute_unsigned(out, STR_WITH_LEN("basetime"), (unsigned long)PL_basetime); /* $^T */
+ NYTP_write_attribute_string(out, STR_WITH_LEN("application"), argv0, len);
+ /* perl constants: */
NYTP_write_attribute_string(out, STR_WITH_LEN("perl_version"), version, sizeof(version) - 1);
- NYTP_write_attribute_signed(out, STR_WITH_LEN("clock_id"), profile_clock);
- NYTP_write_attribute_unsigned(out, STR_WITH_LEN("ticks_per_sec"), ticks_per_sec);
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("nv_size"), sizeof(NV));
+ /* sanity checks: */
+ NYTP_write_attribute_string(out, STR_WITH_LEN("xs_version"), STR_WITH_LEN(XS_VERSION));
NYTP_write_attribute_unsigned(out, STR_WITH_LEN("PL_perldb"), PL_perldb);
- NYTP_write_attribute_string(out, STR_WITH_LEN("application"), argv0, len);
+ /* these are really options: */
+ NYTP_write_attribute_signed(out, STR_WITH_LEN("clock_id"), profile_clock);
+ NYTP_write_attribute_unsigned(out, STR_WITH_LEN("ticks_per_sec"), ticks_per_sec);
+
+ if (1) {
+ struct NYTP_options_t *opt_p = options;
+ const struct NYTP_options_t *const opt_end
+ = options + sizeof(options) / sizeof (struct NYTP_options_t);
+ do {
+ NYTP_write_option_iv(out, opt_p->option_name, opt_p->option_iv);
+ } while (++opt_p < opt_end);
+ }
+
#ifdef HAS_ZLIB
if (compression_level) {
@@ -532,7 +572,7 @@ read_str(pTHX_ NYTP_file ifile, SV *sv) {
if (trace_level >= 19) {
STRLEN len2 = len;
- char *newline = "";
+ const char *newline = "";
if (buf[len2-1] == '\n') {
--len2;
newline = "\\n";
@@ -606,36 +646,36 @@ filename_is_eval(const char *filename, STRLEN filename_len)
* hash_entry in table, insert IGNORED: returns pointer to the actual hash entry
*/
static char
-hash_op (Hash_entry entry, Hash_entry** retval, bool insert)
+hash_op(Hash_table *hashtable, char *key, int key_len, Hash_entry** retval, bool insert)
{
- unsigned long h = hash(entry.key, entry.key_len) % hashtable.size;
+ unsigned long h = hash(key, key_len) % hashtable->size;
- Hash_entry* found = hashtable.table[h];
+ Hash_entry* found = hashtable->table[h];
while(NULL != found) {
- if (found->key_len == entry.key_len
- && memEQ(found->key, entry.key, entry.key_len)
+ if (found->key_len == key_len
+ && memEQ(found->key, key, key_len)
) {
*retval = found;
return 0;
}
- if (NULL == (Hash_entry*)found->next_entry) {
+ if (NULL == found->next_entry) {
if (insert) {
Hash_entry* e;
- Newz(0, e, 1, Hash_entry);
- e->id = next_fid++;
+ Newc(0, e, hashtable->entry_struct_size, char, Hash_entry);
+ memzero(e, hashtable->entry_struct_size);
+ e->id = hashtable->next_id++;
e->next_entry = NULL;
- e->key_len = entry.key_len;
- e->key = (char*)safemalloc(sizeof(char) * e->key_len + 1);
- e->key[e->key_len] = '\0';
- memcpy(e->key, entry.key, e->key_len);
+ e->key_len = key_len;
+ e->key = (char*)safemalloc(sizeof(char) * key_len + 1);
+ e->key[key_len] = '\0';
+ memcpy(e->key, key, key_len);
found->next_entry = e;
- *retval = (Hash_entry*)found->next_entry;
- if (hashtable.last_inserted)
- hashtable.last_inserted->next_inserted = e;
- hashtable.last_inserted = e;
+ *retval = found->next_entry;
+ hashtable->prior_inserted = hashtable->last_inserted;
+ hashtable->last_inserted = e;
return 1;
}
else {
@@ -643,26 +683,26 @@ hash_op (Hash_entry entry, Hash_entry** retval, bool insert)
return -1;
}
}
- found = (Hash_entry*)found->next_entry;
+ found = found->next_entry;
}
if (insert) {
Hash_entry* e;
- Newz(0, e, 1, Hash_entry);
- e->id = next_fid++;
+ Newc(0, e, hashtable->entry_struct_size, char, Hash_entry);
+ memzero(e, hashtable->entry_struct_size);
+ e->id = hashtable->next_id++;
e->next_entry = NULL;
- e->key_len = entry.key_len;
+ e->key_len = key_len;
e->key = (char*)safemalloc(sizeof(char) * e->key_len + 1);
e->key[e->key_len] = '\0';
- memcpy(e->key, entry.key, e->key_len);
+ memcpy(e->key, key, key_len);
- *retval = hashtable.table[h] = e;
+ *retval = hashtable->table[h] = e;
- if (!hashtable.first_inserted)
- hashtable.first_inserted = e;
- if (hashtable.last_inserted)
- hashtable.last_inserted->next_inserted = e;
- hashtable.last_inserted = e;
+ if (!hashtable->first_inserted)
+ hashtable->first_inserted = e;
+ hashtable->prior_inserted = hashtable->last_inserted;
+ hashtable->last_inserted = e;
return 1;
}
@@ -671,12 +711,50 @@ hash_op (Hash_entry entry, Hash_entry** retval, bool insert)
return -1;
}
+static void
+hash_stats(Hash_table *hashtable, int verbosity)
+{
+ int idx = 0;
+ int max_chain_len = 0;
+ int buckets = 0;
+ int items = 0;
+
+ if (verbosity)
+ warn("%s hash: size %d\n", hashtable->name, hashtable->size);
+ if (!hashtable->table)
+ return;
+
+ for (idx=0; idx < hashtable->size; ++idx) {
+ int chain_len = 0;
+
+ Hash_entry *found = hashtable->table[idx];
+ if (!found)
+ continue;
+
+ ++buckets;
+ while (NULL != found) {
+ ++chain_len;
+ ++items;
+ found = found->next_entry;
+ }
+ if (verbosity)
+ warn("%s hash[%3d]: %d items\n", hashtable->name, idx, chain_len);
+ if (chain_len > max_chain_len)
+ max_chain_len = chain_len;
+ }
+ /* XXX would be nice to show a histogram of chain lenths */
+ warn("%s hash: %d of %d buckets used, %d items, max chain %d\n",
+ hashtable->name, buckets, hashtable->size, items, max_chain_len);
+}
+
static void
-emit_fid (Hash_entry *fid_info)
+emit_fid (fid_hash_entry *fid_info)
{
- char *file_name = fid_info->key;
- STRLEN file_name_len = fid_info->key_len;
+ char *file_name = fid_info->he.key;
+ STRLEN file_name_len = fid_info->he.key_len;
+ char *file_name_copy = NULL;
+
if (fid_info->key_abs) {
file_name = fid_info->key_abs;
file_name_len = strlen(file_name);
@@ -686,34 +764,32 @@ emit_fid (Hash_entry *fid_info)
/* Make sure we only use forward slashes in filenames */
if (memchr(file_name, '\\', file_name_len)) {
STRLEN i;
- char *file_name_copy = (char*)safemalloc(file_name_len);
+ file_name_copy = (char*)safemalloc(file_name_len);
for (i=0; i<file_name_len; ++i) {
char ch = file_name[i];
file_name_copy[i] = ch == '\\' ? '/' : ch;
}
- NYTP_write_new_fid(out, fid_info->id, fid_info->eval_fid,
- fid_info->eval_line_num, fid_info->fid_flags,
- fid_info->file_size, fid_info->file_mtime,
- file_name_copy, (I32)file_name_len);
- Safefree(file_name_copy);
- return;
+ file_name = file_name_copy;
}
#endif
- NYTP_write_new_fid(out, fid_info->id, fid_info->eval_fid,
+ NYTP_write_new_fid(out, fid_info->he.id, fid_info->eval_fid,
fid_info->eval_line_num, fid_info->fid_flags,
fid_info->file_size, fid_info->file_mtime,
file_name, (I32)file_name_len);
+
+ if (file_name_copy)
+ Safefree(file_name_copy);
}
/* return true if file is a .pm that was actually loaded as a .pmc */
static int
-fid_is_pmc(pTHX_ Hash_entry *fid_info)
+fid_is_pmc(pTHX_ fid_hash_entry *fid_info)
{
int is_pmc = 0;
- char *file_name = fid_info->key;
- STRLEN len = fid_info->key_len;
+ char *file_name = fid_info->he.key;
+ STRLEN len = fid_info->he.key_len;
if (fid_info->key_abs) {
file_name = fid_info->key_abs;
len = strlen(file_name);
@@ -769,23 +845,23 @@ fmt_fid_flags(pTHX_ int fid_flags, char *buf, Size_t len) {
static void
write_cached_fids()
{
- Hash_entry *e = hashtable.first_inserted;
+ fid_hash_entry *e = (fid_hash_entry*)fidhash.first_inserted;
while (e) {
if ( !(e->fid_flags & NYTP_FIDf_IS_ALIAS) )
emit_fid(e);
- e = (Hash_entry *)e->next_inserted;
+ e = (fid_hash_entry*)e->he.next_inserted;
}
}
-static Hash_entry *
+static fid_hash_entry *
find_autosplit_parent(pTHX_ char* file_name)
{
/* extract basename from file_name, then search for most recent entry
- * in hashtable that has the same basename
+ * in fidhash that has the same basename
*/
- Hash_entry *e = hashtable.first_inserted;
- Hash_entry *match = NULL;
+ fid_hash_entry *e = (fid_hash_entry*)fidhash.first_inserted;
+ fid_hash_entry *match = NULL;
const char *sep = "/";
char *base_end = strstr(file_name, " (autosplit");
char *base_start = rninstr(file_name, base_end, sep, sep+1);
@@ -797,28 +873,28 @@ find_autosplit_parent(pTHX_ char* file_name)
logwarn("find_autosplit_parent of '%.*s' (%s)\n",
(int)base_len, base_start, file_name);
- for ( ; e; e = (Hash_entry *)e->next_inserted) {
+ for ( ; e; e = (fid_hash_entry*)e->he.next_inserted) {
char *e_name;
if (e->fid_flags & NYTP_FIDf_IS_AUTOSPLIT)
continue;
if (trace_level >= 4)
- logwarn("find_autosplit_parent: checking '%.*s'\n", e->key_len, e->key);
+ logwarn("find_autosplit_parent: checking '%.*s'\n", e->he.key_len, e->he.key);
/* skip if key is too small to match */
- if (e->key_len < base_len)
+ if (e->he.key_len < base_len)
continue;
/* skip if the last base_len bytes don't match the base name */
- e_name = e->key + e->key_len - base_len;
+ e_name = e->he.key + e->he.key_len - base_len;
if (memcmp(e_name, base_start, base_len) != 0)
continue;
/* skip if the char before the matched key isn't a separator */
- if (e->key_len > base_len && *(e_name-1) != *sep)
+ if (e->he.key_len > base_len && *(e_name-1) != *sep)
continue;
if (trace_level >= 3)
logwarn("matched autosplit '%.*s' to parent fid %d '%.*s' (%c|%c)\n",
- (int)base_len, base_start, e->id, e->key_len, e->key, *(e_name-1),*sep);
+ (int)base_len, base_start, e->he.id, e->he.key_len, e->he.key, *(e_name-1),*sep);
match = e;
/* keep looking, so we'll return the most recently profiled match */
}
@@ -834,7 +910,7 @@ lookup_file_entry(pTHX_ char* file_name, STRLEN file_name_len) {
entry.key = file_name;
entry.key_len = (unsigned int)file_name_len;
- if (hash_op(entry, &found, 0) == 0)
+ if (hash_op(fidhash, &entry, &found, 0) == 0)
return found;
return NULL;
@@ -856,23 +932,21 @@ static unsigned int
get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
{
- Hash_entry entry, *found, *parent_entry;
+ fid_hash_entry *found, *parent_entry;
AV *src_av = Nullav;
- if (0) memset(&entry, 0, sizeof(entry)); /* handy if debugging */
- entry.key = file_name;
- entry.key_len = (unsigned int)file_name_len;
-
- if (1 != hash_op(entry, &found, (bool)(created_via ? 1 : 0))) {
+ if (1 != hash_op(&fidhash, file_name, file_name_len, (Hash_entry**)&found, (bool)(created_via ? 1 : 0))) {
/* found existing entry or else didn't but didn't create new one either */
if (trace_level >= 7) {
if (found)
- logwarn("fid %d: %.*s\n", found->id, found->key_len, found->key);
- else logwarn("fid -: %.*s not profiled\n", entry.key_len, entry.key);
+ logwarn("fid %d: %.*s\n", found->he.id, found->he.key_len, found->he.key);
+ else logwarn("fid -: %.*s not profiled\n", (int)file_name_len, file_name);
}
- return (found) ? found->id : 0;
+ return (found) ? found->he.id : 0;
}
/* inserted new entry */
+ if (fidhash.prior_inserted)
+ fidhash.prior_inserted->next_inserted = fidhash.last_inserted;
/* if this is a synthetic filename for a string eval
* ie "(eval 42)[/some/filename.pl:line]"
@@ -942,7 +1016,7 @@ get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
&& (parent_entry = find_autosplit_parent(aTHX_ file_name))
) {
/* copy some details from parent_entry to found */
- found->id = parent_entry->id;
+ found->he.id = parent_entry->he.id;
found->eval_fid = parent_entry->eval_fid;
found->eval_line_num = parent_entry->eval_line_num;
found->file_size = parent_entry->file_size;
@@ -951,15 +1025,15 @@ get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
/* prevent write_cached_fids() from writing this fid */
found->fid_flags |= NYTP_FIDf_IS_ALIAS;
/* avoid a gap in the fid sequence */
- --next_fid;
+ --fidhash.next_id;
/* write a log message if tracing */
if (trace_level >= 2)
logwarn("Use fid %2u (after %2u:%-4u) %x e%u:%u %.*s %s\n",
- found->id, last_executed_fid, last_executed_line,
+ found->he.id, last_executed_fid, last_executed_line,
found->fid_flags, found->eval_fid, found->eval_line_num,
- found->key_len, found->key, (found->key_abs) ? found->key_abs : "");
+ found->he.key_len, found->he.key, (found->key_abs) ? found->key_abs : "");
/* bail out without calling emit_fid() */
- return found->id;
+ return found->he.id;
}
/* determine absolute path if file_name is relative */
@@ -1018,13 +1092,13 @@ get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
/* is source code available? */
/* source only available if PERLDB_LINE or PERLDB_SAVESRC is true */
/* which we set if savesrc option is enabled */
- if ( (src_av = GvAV(gv_fetchfile_flags(found->key, found->key_len, 0))) )
+ if ( (src_av = GvAV(gv_fetchfile_flags(found->he.key, found->he.key_len, 0))) )
if (av_len(src_av) > -1)
found->fid_flags |= NYTP_FIDf_HAS_SRC;
/* flag "perl -e '...'" and "perl -" as string evals */
- if (found->key[0] == '-' && (found->key_len == 1 ||
- (found->key[1] == 'e' && found->key_len == 2)))
+ if (found->he.key[0] == '-' && (found->he.key_len == 1 ||
+ (found->he.key[1] == 'e' && found->he.key_len == 2)))
found->fid_flags |= NYTP_FIDf_IS_EVAL;
/* if it's a string eval or a synthetic filename from CODE ref in @INC,
@@ -1033,7 +1107,7 @@ get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
if (found->eval_fid
|| (found->fid_flags & NYTP_FIDf_IS_EVAL)
|| (profile_opts & NYTP_OPTf_SAVESRC)
- || (found->key_len > 10 && found->key[9] == 'x' && strnEQ(found->key, "/loader/0x", 10))
+ || (found->he.key_len > 10 && found->he.key[9] == 'x' && strnEQ(found->he.key, "/loader/0x", 10))
) {
found->fid_flags |= NYTP_FIDf_SAVE_SRC;
}
@@ -1045,14 +1119,26 @@ get_file_id(pTHX_ char* file_name, STRLEN file_name_len, int created_via)
/* including last_executed_fid can be handy for tracking down how
* a file got loaded */
logwarn("New fid %2u (after %2u:%-4u) 0x%02x e%u:%u %.*s %s %s\n",
- found->id, last_executed_fid, last_executed_line,
+ found->he.id, last_executed_fid, last_executed_line,
found->fid_flags, found->eval_fid, found->eval_line_num,
- found->key_len, found->key, (found->key_abs) ? found->key_abs : "",
+ found->he.key_len, found->he.key, (found->key_abs) ? found->key_abs : "",
fmt_fid_flags(aTHX_ found->fid_flags, buf, sizeof(buf))
);
}
- return found->id;
+ return found->he.id;
+}
+
+
+/**
+ * Return a unique persistent id number for a string.
+ */
+static unsigned int
+get_str_id(pTHX_ char* str, STRLEN len)
+{
+ str_hash_entry *found;
+ hash_op(&strhash, str, len, (Hash_entry**)&found, 1);
+ return found->he.id;
}
static UV
@@ -1568,6 +1654,10 @@ DB_leave(pTHX_ OP *op, OP *prev_op)
static void
set_option(pTHX_ const char* option, const char* value)
{
+ if (!value || !*value)
+ croak("%s: invalid option", "NYTProf set_option");
+ if (!value || !*value)
+ croak("%s: '%s' has no value", "NYTProf set_option", option);
if (strEQ(option, "file")) {
strncpy(PROF_output_file, value, MAXPATHLEN);
@@ -1607,14 +1697,19 @@ set_option(pTHX_ const char* option, const char* value)
if (atoi(value))
PL_exit_flags |= PERL_EXIT_DESTRUCT_END;
}
+ else if (strEQ(option, "libcexit")) {
+ if (atoi(value))
+ atexit(finish_profile_nocontext);
+ }
else {
- struct NYTP_int_options_t *opt_p = options;
- const struct NYTP_int_options_t *const opt_end
- = options + sizeof(options) / sizeof (struct NYTP_int_options_t);
+
+ struct NYTP_options_t *opt_p = options;
+ const struct NYTP_options_t *const opt_end
+ = options + sizeof(options) / sizeof (struct NYTP_options_t);
bool found = FALSE;
do {
if (strEQ(option, opt_p->option_name)) {
- opt_p->option_value = strtol(value, NULL, 0);
+ opt_p->option_iv = (IV)strtol(value, NULL, 0);
found = TRUE;
break;
}
@@ -1671,7 +1766,7 @@ open_output_file(pTHX_ char *filename)
filename, fopen_errno, strerror(fopen_errno), hint);
}
if (trace_level >= 1)
- logwarn("~ opened %s\n", filename);
+ logwarn("~ opened %s at %.6f\n", filename, gettimeofday_nv());
output_header(aTHX);
}
@@ -1701,7 +1796,7 @@ close_output_file(pTHX) {
out = NULL;
if (trace_level >= 1)
- logwarn("~ closed file.\n");
+ logwarn("~ closed file at %.6f\n", timeofday);
}
@@ -1715,7 +1810,7 @@ reinit_if_forked(pTHX)
/* we're now the child process */
if (trace_level >= 1)
- logwarn("~ new pid %d (was %d) forkdepth %d\n", getpid(), last_pid, profile_forkdepth);
+ logwarn("~ new pid %d (was %d) forkdepth %ld\n", getpid(), last_pid, profile_forkdepth);
/* reset state */
last_pid = getpid();
@@ -1775,7 +1870,7 @@ new_sub_call_info_av(pTHX)
typedef struct subr_entry_st subr_entry_t;
struct subr_entry_st {
unsigned int already_counted;
- unsigned int subr_prof_depth;
+ U32 subr_prof_depth;
long unsigned subr_call_seqn;
I32 prev_subr_entry_ix; /* ix to callers subr_entry */
@@ -1871,8 +1966,8 @@ subr_entry_destroy(pTHX_ subr_entry_t *subr_entry)
/* ignore the typical second (fallback) destroy */
&& !(subr_entry->prev_subr_entry_ix == subr_entry_ix && subr_entry->already_counted==1)
) {
- logwarn("%2d << %s::%s done %s\n",
- subr_entry->subr_prof_depth,
+ logwarn("%2u << %s::%s done %s\n",
+ (unsigned int)subr_entry->subr_prof_depth,
subr_entry->called_subpkg_pv,
(subr_entry->called_subnam_sv && SvOK(subr_entry->called_subnam_sv))
? SvPV_nolen(subr_entry->called_subnam_sv)
@@ -1908,8 +2003,11 @@ incr_sub_inclusive_time(pTHX_ subr_entry_t *subr_entry)
NV incl_subr_ticks, excl_subr_ticks;
SV *sv_tmp;
AV *subr_call_av;
+ time_of_day_t sub_end_time;
+ long ticks, overflow;
- if (subr_entry->called_subnam_sv == &PL_sv_undef) {
+ /* an undef SV is a special marker used by subr_entry_setup */
+ if (subr_entry->called_subnam_sv && !SvOK(subr_entry->called_subnam_sv)) {
if (trace_level)
logwarn("Don't know name of called sub, assuming xsub/builtin exited via an exception (which isn't handled yet)\n");
subr_entry->already_counted++;
@@ -1927,12 +2025,9 @@ incr_sub_inclusive_time(pTHX_ subr_entry_t *subr_entry)
/* statement overheads we've accumulated since we entered the sub */
overhead_ticks = cumulative_overhead_ticks - subr_entry->initial_overhead_ticks;
- /* seconds spent in subroutines called by this subroutine */
+ /* ticks spent in subroutines called by this subroutine */
called_sub_ticks = cumulative_subr_ticks - subr_entry->initial_subr_ticks;
- time_of_day_t sub_end_time;
- long ticks, overflow;
-
/* calculate ticks since we entered the sub */
get_time_of_day(sub_end_time);
get_ticks_between(NV, subr_entry->initial_call_timeofday, sub_end_time, ticks, overflow);
@@ -2039,19 +2134,17 @@ incr_sub_inclusive_time(pTHX_ subr_entry_t *subr_entry)
sv_inc(AvARRAY(subr_call_av)[NYTP_SCi_CALL_COUNT]);
}
- if (trace_level >= 5)
- logwarn("%2d <- %s %"NVff"s excl = %"NVff"s incl - %"NVff"s (%"NVff"-%"NVff"), oh %"NVff"-%"NVff"=%"NVff"t, d%d @%d:%d #%lu %p\n",
- subr_entry->subr_prof_depth,
- called_subname_pv,
- excl_subr_ticks/ticks_per_sec,
- incl_subr_ticks/ticks_per_sec,
- called_sub_ticks/ticks_per_sec,
- cumulative_subr_ticks/ticks_per_sec,
- subr_entry->initial_subr_ticks/ticks_per_sec,
+ if (trace_level >= 5) {
+ logwarn("%2u <- %s %"NVgf" excl = %"NVgf"t incl - %"NVgf"t (%"NVgf"-%"NVgf"), oh %"NVff"-%"NVff"=%"NVff"t, d%d @%d:%d #%lu %p\n",
+ (unsigned int)subr_entry->subr_prof_depth, called_subname_pv,
+ excl_subr_ticks, incl_subr_ticks,
+ called_sub_ticks,
+ cumulative_subr_ticks, subr_entry->initial_subr_ticks,
cumulative_overhead_ticks, subr_entry->initial_overhead_ticks, overhead_ticks,
(int)subr_entry->called_cv_depth,
subr_entry->caller_fid, subr_entry->caller_line,
subr_entry->subr_call_seqn, (void*)subr_entry);
+ }
/* only count inclusive time for the outer-most calls */
if (subr_entry->called_cv_depth <= 1) {
@@ -2070,6 +2163,10 @@ incr_sub_inclusive_time(pTHX_ subr_entry_t *subr_entry)
excl_time_sv = *av_fetch(subr_call_av, NYTP_SCi_EXCL_TICKS, 1);
sv_setnv(excl_time_sv, SvNV(excl_time_sv)+excl_subr_ticks);
+ if (opt_calls && out) {
+ NYTP_write_call_return(out, subr_entry->subr_prof_depth, called_subname_pv, incl_subr_ticks, excl_subr_ticks);
+ }
+
subr_entry_destroy(aTHX_ subr_entry);
cumulative_subr_ticks += excl_subr_ticks;
@@ -2254,7 +2351,14 @@ subr_entry_setup(pTHX_ COP *prev_cop, subr_entry_t *clone_subr_entry, OPCODE op_
}
}
else {
- subr_entry->called_subnam_sv = newSV(0); /* see incr_sub_inclusive_time */
+ /* resolve_sub_to_cv couldn't work out what's being called,
+ * possibly because it's something that'll cause pp_entersub to croak
+ * anyway. So we mark the subr_entry in a particular way and hope that
+ * pp_subcall_profiler() can fill in the details.
+ * If there is an exception then we'll wind up in incr_sub_inclusive_time
+ * which will see this mark and ignore the call.
+ */
+ subr_entry->called_subnam_sv = newSV(0);
}
subr_entry->called_is_xs = NULL; /* work it out later */
}
@@ -2403,8 +2507,8 @@ subr_entry_setup(pTHX_ COP *prev_cop, subr_entry_t *clone_subr_entry, OPCODE op_
}
if (trace_level >= 4) {
- logwarn("%2d >> %s at %u:%d from %s::%s %s %s\n",
- subr_entry->subr_prof_depth,
+ logwarn("%2u >> %s at %u:%d from %s::%s %s %s\n",
+ (unsigned int)subr_entry->subr_prof_depth,
PL_op_name[op_type],
subr_entry->caller_fid, subr_entry->caller_line,
subr_entry->caller_subpkg_pv,
@@ -2421,6 +2525,10 @@ subr_entry_setup(pTHX_ COP *prev_cop, subr_entry_t *clone_subr_entry, OPCODE op_
*/
save_destructor_x(incr_sub_inclusive_time_ix, INT2PTR(void *, (IV)subr_entry_ix));
+ if (opt_calls >= 2 && out) {
+ NYTP_write_call_entry(out, subr_entry->caller_fid, subr_entry->caller_line);
+ }
+
SETERRNO(saved_errno, 0);
return subr_entry_ix;
@@ -2569,7 +2677,7 @@ pp_subcall_profiler(pTHX_ int is_slowop)
subr_entry = subr_entry_ix_ptr(this_subr_entry_ix);
/* detect wierdness/corruption */
- assert(subr_entry->caller_fid < next_fid);
+ assert(subr_entry->caller_fid < fidhash.next_id);
/* Check if this call has already been counted because the op performed
* a leave_scope(). E.g., OP_SUBSTCONT at end of s/.../\1/
@@ -2577,8 +2685,8 @@ pp_subcall_profiler(pTHX_ int is_slowop)
*/
if (subr_entry->already_counted) {
if (trace_level >= 9)
- logwarn("%2d -- %s::%s already counted %s\n",
- subr_entry->subr_prof_depth,
+ logwarn("%2u -- %s::%s already counted %s\n",
+ (unsigned int)subr_entry->subr_prof_depth,
subr_entry->called_subpkg_pv,
(subr_entry->called_subnam_sv && SvOK(subr_entry->called_subnam_sv))
? SvPV_nolen(subr_entry->called_subnam_sv)
@@ -2692,8 +2800,8 @@ pp_subcall_profiler(pTHX_ int is_slowop)
subr_entry->already_counted++;
if (trace_level >= 4) {
- logwarn("%2d ->%4s %s::%s from %s::%s @%u:%u (d%d, oh %"NVff"t, sub %"NVff"s) #%lu\n",
- subr_entry->subr_prof_depth,
+ logwarn("%2u ->%4s %s::%s from %s::%s @%u:%u (d%d, oh %"NVff"t, sub %"NVff"s) #%lu\n",
+ (unsigned int)subr_entry->subr_prof_depth,
(subr_entry->called_is_xs) ? subr_entry->called_is_xs : "sub",
subr_entry->called_subpkg_pv,
subr_entry->called_subnam_sv ? SvPV_nolen(subr_entry->called_subnam_sv) : "(null)",
@@ -2828,7 +2936,7 @@ disable_profile(pTHX)
is_profiling = 0;
}
if (trace_level)
- logwarn("~ disable_profile (previously %s, pid %d, trace %d)\n",
+ logwarn("~ disable_profile (previously %s, pid %d, trace %ld)\n",
prev_is_profiling ? "enabled" : "disabled", getpid(), trace_level);
return prev_is_profiling;
}
@@ -2837,6 +2945,7 @@ disable_profile(pTHX)
static void
finish_profile(pTHX)
{
+ /* can be called after the perl interp is destroyed, via libcexit */
int saved_errno = errno;
#ifdef MULTIPLICITY
if (orig_my_perl && my_perl != orig_my_perl)
@@ -2847,8 +2956,8 @@ finish_profile(pTHX)
#endif
if (trace_level >= 1)
- logwarn("~ finish_profile (overhead %"NVff"s, is_profiling %d)\n",
- cumulative_overhead_ticks/ticks_per_sec, is_profiling);
+ logwarn("~ finish_profile (overhead %gt, is_profiling %d)\n",
+ cumulative_overhead_ticks, is_profiling);
/* write data for final statement, unless DB_leave has already */
if (!profile_leave || opt_use_db_sub)
@@ -2858,8 +2967,17 @@ finish_profile(pTHX)
close_output_file(aTHX);
+ if (trace_level >= 2) {
+ hash_stats(&fidhash, 0);
+ hash_stats(&strhash, 0);
+ }
+
/* reset sub profiler data */
- hv_clear(sub_callers_hv);
+ if (HvKEYS(sub_callers_hv)) {
+ /* HvKEYS check avoids hv_clear() if interp has been destroyed RT#86548 */
+ hv_clear(sub_callers_hv);
+ }
+
/* reset other state */
cumulative_overhead_ticks = 0;
cumulative_subr_ticks = 0;
@@ -2869,6 +2987,15 @@ finish_profile(pTHX)
static void
+finish_profile_nocontext()
+{
+ /* can be called after the perl interp is destroyed, via libcexit */
+ dTHX;
+ finish_profile(aTHX);
+}
+
+
+static void
_init_profiler_clock(pTHX)
{
#ifdef HAS_CLOCK_GETTIME
@@ -2882,8 +3009,8 @@ _init_profiler_clock(pTHX)
/* downgrade to CLOCK_REALTIME if desired clock not available */
if (clock_gettime(profile_clock, &start_time) != 0) {
if (trace_level)
- logwarn("~ clock_gettime clock %d not available (%s) using CLOCK_REALTIME instead\n",
- profile_clock, strerror(errno));
+ logwarn("~ clock_gettime clock %ld not available (%s) using CLOCK_REALTIME instead\n",
+ (long)profile_clock, strerror(errno));
profile_clock = CLOCK_REALTIME;
/* check CLOCK_REALTIME as well, just in case */
if (clock_gettime(profile_clock, &start_time) != 0)
@@ -2892,7 +3019,7 @@ _init_profiler_clock(pTHX)
}
#else
if (profile_clock != -1) { /* user tried to select different clock */
- logwarn("clock %d not available (clock_gettime not supported on this system)\n", profile_clock);
+ logwarn("clock %ld not available (clock_gettime not supported on this system)\n", (long)profile_clock);
profile_clock = -1;
}
#endif
@@ -2952,8 +3079,8 @@ init_profiler(pTHX)
_init_profiler_clock(aTHX);
if (trace_level)
- logwarn("~ init_profiler for pid %d, clock %d, start %d, perldb 0x%lx, exitf 0x%lx\n",
- last_pid, profile_clock, profile_start,
+ logwarn("~ init_profiler for pid %d, clock %ld, tps %d, start %d, perldb 0x%lx, exitf 0x%lx\n",
+ last_pid, (long)profile_clock, ticks_per_sec, profile_start,
(long unsigned)PL_perldb, (long unsigned)PL_exit_flags);
if (get_hv("DB::sub", 0) == NULL) {
@@ -2971,10 +3098,8 @@ init_profiler(pTHX)
#endif
/* create file id mapping hash */
- hashtable.table = (Hash_entry**)safemalloc(sizeof(Hash_entry*) * hashtable.size);
- memset(hashtable.table, 0, sizeof(Hash_entry*) * hashtable.size);
-
- open_output_file(aTHX_ PROF_output_file);
+ fidhash.table = (Hash_entry**)safemalloc(sizeof(Hash_entry*) * fidhash.size);
+ memset(fidhash.table, 0, sizeof(Hash_entry*) * fidhash.size);
/* redirect opcodes for statement profiling */
Newxc(PL_ppaddr_orig, OP_max, void *, orig_ppaddr_t);
@@ -3173,7 +3298,7 @@ parse_DBsub_value(pTHX_ SV *sv, STRLEN *filename_len_p, UV *first_line_p, UV *la
if ('-' == *++last) { /* skip past dash, is next char a minus? */
warn("Negative last line number in %%DB::sub entry '%s' for %s\n",
filename, sub_name);
- last = "0";
+ last = (char *)"0";
}
if (last_line_p)
*last_line_p = atoi(last);
@@ -3300,7 +3425,7 @@ write_sub_line_ranges(pTHX)
/* get name of file that contained first profiled sub in 'main::' */
SV *pkg_filename_sv = sub_pkg_filename_sv(aTHX_ runtime, runtime_len);
if (!pkg_filename_sv) { /* no subs in main, so guess */
- sv_setpvn(sv, hashtable.first_inserted->key, hashtable.first_inserted->key_len);
+ sv_setpvn(sv, fidhash.first_inserted->key, fidhash.first_inserted->key_len);
}
else if (SvOK(pkg_filename_sv)) {
sv_setsv(sv, pkg_filename_sv);
@@ -3461,8 +3586,8 @@ write_sub_callers(pTHX)
}
}
if (negative_time_calls) {
- logwarn("Warning: %d subroutine calls had negative time! See TROUBLESHOOTING in the documentation. (Clock %d)\n",
- negative_time_calls, profile_clock);
+ logwarn("Warning: %d subroutine calls had negative time! See TROUBLESHOOTING in the documentation. (Clock %ld)\n",
+ negative_time_calls, (long)profile_clock);
}
}
@@ -3470,7 +3595,7 @@ write_sub_callers(pTHX)
static void
write_src_of_files(pTHX)
{
- Hash_entry *e;
+ fid_hash_entry *e;
int t_has_src = 0;
int t_save_src = 0;
int t_no_src = 0;
@@ -3479,25 +3604,25 @@ write_src_of_files(pTHX)
if (trace_level >= 1)
logwarn("~ writing file source code\n");
- for (e = hashtable.first_inserted; e; e = (Hash_entry *)e->next_inserted) {
+ for (e = (fid_hash_entry*)fidhash.first_inserted; e; e = (fid_hash_entry*)e->he.next_inserted) {
I32 lines;
int line;
- AV *src_av = GvAV(gv_fetchfile_flags(e->key, e->key_len, 0));
+ AV *src_av = GvAV(gv_fetchfile_flags(e->he.key, e->he.key_len, 0));
if ( !(e->fid_flags & NYTP_FIDf_HAS_SRC) ) {
- char *hint = "";
+ const char *hint = "";
++t_no_src;
if (src_av && av_len(src_av) > -1) /* sanity check */
hint = " (NYTP_FIDf_HAS_SRC not set but src available!)";
if (trace_level >= 3 || *hint)
logwarn("fid %d has no src saved for %.*s%s\n",
- e->id, e->key_len, e->key, hint);
+ e->he.id, e->he.key_len, e->he.key, hint);
continue;
}
if (!src_av) { /* sanity check */
++t_no_src;
logwarn("fid %d has no src but NYTP_FIDf_HAS_SRC is set! (%.*s)\n",
- e->id, e->key_len, e->key);
+ e->he.id, e->he.key_len, e->he.key);
continue;
}
++t_has_src;
@@ -3510,16 +3635,16 @@ write_src_of_files(pTHX)
lines = av_len(src_av); /* -1 is empty, 1 is 1 line etc, 0 shouldn't happen */
if (trace_level >= 3)
logwarn("fid %d has %ld src lines for %.*s\n",
- e->id, (long)lines, e->key_len, e->key);
+ e->he.id, (long)lines, e->he.key_len, e->he.key);
for (line = 1; line <= lines; ++line) { /* lines start at 1 */
SV **svp = av_fetch(src_av, line, 0);
STRLEN len = 0;
const char *src = (svp) ? SvPV(*svp, len) : "";
/* outputting the tag and fid for each (non empty) line
* is a little inefficient, but not enough to worry about */
- NYTP_write_src_line(out, e->id, line, src, (I32)len); /* includes newline */
+ NYTP_write_src_line(out, e->he.id, line, src, (I32)len); /* includes newline */
if (trace_level >= 8) {
- logwarn("fid %d src line %d: %s%s", e->id, line, src,
+ logwarn("fid %d src line %d: %s%s", e->he.id, line, src,
(len && src[len-1]=='\n') ? "" : "\n");
}
++t_lines;
@@ -3708,6 +3833,7 @@ typedef struct loader_state_profiler {
HV *sub_subinfo_hv;
HV *live_pids_hv;
HV *attr_hv;
+ HV *option_hv;
HV *file_info_stash;
/* these times don't reflect profile_enable & profile_disable calls */
NV profiler_start_time;
@@ -3719,6 +3845,7 @@ static void
load_discount_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
{
Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
+ PERL_UNUSED_ARG(tag);
if (trace_level >= 8)
logwarn("discounting next statement after %u:%d\n",
@@ -3873,7 +4000,7 @@ load_new_fid_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
SvPV_nolen(filename_sv), file_num,
fmt_fid_flags(aTHX_ fid_flags, buf, sizeof(buf)), eval_file_num);
/* so make it look like a real file instead of an eval */
- av_store(av, NYTP_FIDi_EVAL_FI, &PL_sv_undef);
+ av_store(av, NYTP_FIDi_EVAL_FI, NULL);
eval_file_num = 0;
eval_line_num = 0;
}
@@ -3887,7 +4014,7 @@ load_new_fid_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
}
}
else {
- av_store(av, NYTP_FIDi_EVAL_FI, &PL_sv_undef);
+ av_store(av, NYTP_FIDi_EVAL_FI, NULL);
}
av_store(av, NYTP_FIDi_EVAL_FID, (eval_file_num) ? newSVuv(eval_file_num) : &PL_sv_no);
av_store(av, NYTP_FIDi_EVAL_LINE, (eval_file_num) ? newSVuv(eval_line_num) : &PL_sv_no);
@@ -3895,8 +4022,8 @@ load_new_fid_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
av_store(av, NYTP_FIDi_FLAGS, newSVuv(fid_flags));
av_store(av, NYTP_FIDi_FILESIZE, newSVuv(file_size));
av_store(av, NYTP_FIDi_FILEMTIME, newSVuv(file_mtime));
- av_store(av, NYTP_FIDi_PROFILE, &PL_sv_undef);
- av_store(av, NYTP_FIDi_HAS_EVALS, &PL_sv_undef);
+ av_store(av, NYTP_FIDi_PROFILE, NULL);
+ av_store(av, NYTP_FIDi_HAS_EVALS, NULL);
av_store(av, NYTP_FIDi_SUBS_DEFINED, newRV_noinc((SV*)newHV()));
av_store(av, NYTP_FIDi_SUBS_CALLED, newRV_noinc((SV*)newHV()));
}
@@ -4197,7 +4324,7 @@ load_pid_end_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
store_attrib_sv(aTHX_ state->attr_hv, STR_WITH_LEN("profiler_end_time"),
newSVnv(end_time));
- state->profiler_duration += end_time - state->profiler_start_time;
+ state->profiler_duration += state->profiler_end_time - state->profiler_start_time;
store_attrib_sv(aTHX_ state->attr_hv, STR_WITH_LEN("profiler_duration"),
newSVnv(state->profiler_duration));
@@ -4234,6 +4361,38 @@ load_attribute_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ..
value_utf8 ? SVf_UTF8 : 0));
}
+static void
+load_option_callback(Loader_state_base *cb_data, const nytp_tax_index tag, ...)
+{
+ Loader_state_profiler *state = (Loader_state_profiler *)cb_data;
+ dTHXa(state->interp);
+ va_list args;
+ char *key;
+ unsigned long key_len;
+ unsigned int key_utf8;
+ char *value;
+ unsigned long value_len;
+ unsigned int value_utf8;
+ SV *value_sv;
+
+ va_start(args, tag);
+
+ key = va_arg(args, char *);
+ key_len = va_arg(args, unsigned long);
+ key_utf8 = va_arg(args, unsigned int);
+
+ value = va_arg(args, char *);
+ value_len = va_arg(args, unsigned long);
+ value_utf8 = va_arg(args, unsigned int);
+
+ va_end(args);
+
+ value_sv = newSVpvn_flags(value, value_len, value_utf8 ? SVf_UTF8 : 0);
+ (void)hv_store(state->option_hv, key, key_utf8 ? -(I32)key_len : key_len, value_sv, 0);
+ if (trace_level >= 1)
+ logwarn("! %.*s = '%s'\n", (int) key_len, key, SvPV_nolen(value_sv));
+}
+
struct perl_callback_info_t {
const char *description;
STRLEN len;
@@ -4245,6 +4404,7 @@ static struct perl_callback_info_t callback_info[nytp_tag_max] =
{STR_WITH_LEN("[no tag]"), NULL},
{STR_WITH_LEN("VERSION"), "uu"},
{STR_WITH_LEN("ATTRIBUTE"), "33"},
+ {STR_WITH_LEN("OPTION"), "33"},
{STR_WITH_LEN("COMMENT"), "3"},
{STR_WITH_LEN("TIME_BLOCK"), "iuuuu"},
{STR_WITH_LEN("TIME_LINE"), "iuu"},
@@ -4257,7 +4417,9 @@ static struct perl_callback_info_t callback_info[nytp_tag_max] =
{STR_WITH_LEN("PID_END"), "un"},
{STR_WITH_LEN("[string]"), NULL},
{STR_WITH_LEN("[string utf8]"), NULL},
- {STR_WITH_LEN("START_DEFLATE"), ""}
+ {STR_WITH_LEN("START_DEFLATE"), ""},
+ {STR_WITH_LEN("SUB_ENTRY"), "uu"},
+ {STR_WITH_LEN("SUB_RETURN"), "unns"}
};
static void
@@ -4381,6 +4543,9 @@ static loader_callback perl_callbacks[nytp_tag_max] =
load_perl_callback,
load_perl_callback,
load_perl_callback,
+ load_perl_callback,
+ load_perl_callback,
+ load_perl_callback,
load_perl_callback
};
static loader_callback processing_callbacks[nytp_tag_max] =
@@ -4388,6 +4553,7 @@ static loader_callback processing_callbacks[nytp_tag_max] =
0,
0, /* version */
load_attribute_callback,
+ load_option_callback,
0, /* comment */
load_time_callback,
load_time_callback,
@@ -4400,6 +4566,8 @@ static loader_callback processing_callbacks[nytp_tag_max] =
load_pid_end_callback,
0, /* string */
0, /* string utf8 */
+ 0, /* sub entry */
+ 0, /* sub return */
0 /* start deflate */
};
@@ -4483,8 +4651,7 @@ load_profile_data_from_stream(loader_callback *callbacks,
if (c == NYTP_TAG_TIME_BLOCK) {
block_line_num = read_u32(in);
sub_line_num = read_u32(in);
- if (profile_blocks)
- tag = nytp_time_block;
+ tag = nytp_time_block;
}
/* Because it happens that the two "optional" arguments are
@@ -4524,6 +4691,28 @@ load_profile_data_from_stream(loader_callback *callbacks,
break;
}
+ case NYTP_TAG_SUB_ENTRY:
+ {
+ unsigned int file_num = read_u32(in);
+ unsigned int line_num = read_u32(in);
+
+ if (callbacks[nytp_sub_entry])
+ callbacks[nytp_sub_entry](state, nytp_sub_entry, file_num, line_num);
+ break;
+ }
+
+ case NYTP_TAG_SUB_RETURN:
+ {
+ unsigned int depth = read_u32(in);
+ NV incl_time = read_nv(in);
+ NV excl_time = read_nv(in);
+ SV *subname = read_str(aTHX_ in, tmp_str1_sv);
+
+ if (callbacks[nytp_sub_return])
+ callbacks[nytp_sub_return](state, nytp_sub_return, depth, incl_time, excl_time, subname);
+ break;
+ }
+
case NYTP_TAG_SUB_INFO:
{
unsigned int fid = read_u32(in);
@@ -4607,6 +4796,27 @@ load_profile_data_from_stream(loader_callback *callbacks,
break;
}
+ case NYTP_TAG_OPTION:
+ {
+ char *value, *key_end;
+ char *end = NYTP_gets(in, &buffer, &buffer_len);
+ if (NULL == end)
+ /* probably EOF */
+ croak("Profile format error reading attribute");
+ --end; /* end, as returned, points 1 after the \n */
+ if ((NULL == (value = (char *)memchr(buffer, '=', end - buffer)))) {
+ logwarn("option malformed '%s'\n", buffer);
+ continue;
+ }
+ key_end = value++;
+
+ callbacks[nytp_option](state, nytp_option, buffer,
+ (unsigned long)(key_end - buffer),
+ 0, value,
+ (unsigned long)(end - value), 0);
+ break;
+ }
+
case NYTP_TAG_COMMENT:
{
char *end = NYTP_gets(in, &buffer, &buffer_len);
@@ -4670,6 +4880,7 @@ load_profile_to_hv(pTHX_ NYTP_file in)
state.sub_subinfo_hv = newHV();
state.live_pids_hv = newHV();
state.attr_hv = newHV();
+ state.option_hv = newHV();
state.file_info_stash = gv_stashpv("Devel::NYTProf::FileInfo", GV_ADDWARN);
av_extend(state.fid_fileinfo_av, 64); /* grow them up front. */
@@ -4729,6 +4940,8 @@ load_profile_to_hv(pTHX_ NYTP_file in)
profile_modes = newHV();
(void)hv_stores(profile_hv, "attribute",
newRV_noinc((SV*)state.attr_hv));
+ (void)hv_stores(profile_hv, "option",
+ newRV_noinc((SV*)state.option_hv));
(void)hv_stores(profile_hv, "fid_fileinfo",
newRV_noinc((SV*)state.fid_fileinfo_av));
(void)hv_stores(profile_hv, "fid_srclines",
@@ -0,0 +1,26 @@
+# Devel::NYTProf
+
+Devel::NYTProf is a powerful feature-rich perl source code profiler.
+
+[](http://travis-ci.org/timbunce/devel-nytprof)
+
+For more information see:
+
+ http://www.slideshare.net/Tim.Bunce/develnytprof-v4-at-yapceu-201008-4906467
+ http://blog.timbunce.org/tag/nytprof/
+
+## DOWNLOAD AND INSTALLATION
+
+Download a release from CPAN using your favorite tool, such as cpanm. Or else
+from https://metacpan.org/release/Devel-NYTProf and then unpack the tar.gz file.
+
+You're most welcome to contribute, in which case cloning or forking the git
+repo is a good place to start.
+
+To build and install, just incant the typical mantra:
+
+ perl Makefile.PL
+ make
+ make test
+ make install
+
@@ -1,125 +0,0 @@
-#! /usr/bin/env perl
-# vim: ts=8 sw=4 sts=4 expandtab:
-##########################################################
-## This script is part of the Devel::NYTProf distribution
-##
-## Copyright, contact and other information can be found
-## at the bottom of this file, or by going to:
-## http://search.cpan.org/perldoc?Devel::NYTProf
-##
-###########################################################
-## $Id$
-###########################################################
-use warnings;
-use strict;
-
-use Carp;
-use Config;
-use Getopt::Long;
-use Benchmark qw(:hireswallclock timethese cmpthese);
-use Devel::NYTProf::Data; # just to print path
-
-GetOptions(
- 'v|verbose' => \my $opt_verbose,
-) or exit 1;
-
-my $regex = shift;
-
-my $subs_count = shift || 2000;
-my $loop_count = shift || 1000;
-
-# simple benchmark script to measure profiling overhead
-my $test_script = "benchmark_code.pl";
-open my $fh, ">", $test_script or die "Can't write to $test_script: $!\n";
-print $fh q{
- my $subs_count = shift || die "No subs count";
- my $loop_count = shift || die "No loop count";
- sub foo {
- my $loop = shift;
- my $a = 0;
- while ($loop-- > 0) { ++$a; ++$a; ++$a; }
- }
- while ($subs_count-- > 0) {
- foo($loop_count)
- }
-};
-close $fh or die "Error writing to $test_script: $!\n";
-END { unlink $test_script };
-
-
-my %tests = (
- baseline => {
- perlargs => '',
- },
- dprof => {
- perlargs => '-d:DProf',
- datafile => 'tmon.out',
- },
- fastprof => {
- perlargs => '-MDevel::FastProf',
- datafile => 'fastprof.out',
- },
- profit => {
- perlargs => '-MDevel::Profit',
- datafile => 'profit.out',
- },
- nytprof_o => {
- env => [ NYTPROF => 'use_db_sub=0:file=nytprof_o.out' ],
- perlargs => '-d:NYTProf',
- datafile => 'nytprof_o.out',
- },
- nytprof_s => {
- env => [ NYTPROF => 'use_db_sub=1:file=nytprof_s.out' ],
- perlargs => '-d:NYTProf',
- datafile => 'nytprof_s.out',
- },
- nytprof_ob => {
- env => [ NYTPROF => 'blocks:file=nytprof_ob.out' ],
- perlargs => '-d:NYTProf',
- datafile => 'nytprof_ob.out',
- },
-);
-
-my %test_subs;
-while ( my ($testname, $testinfo) = each %tests ) {
- if ($regex && $testname ne 'baseline' && $testname !~ m/$regex/o) {
- warn "Skipped $testname\n";
- next;
- }
- if (!run_test($testinfo, 1, 1)) {
- warn "Can't run $testname profiler - skipped\n";
- next;
- }
- $testinfo->{testname} = $testname;
- $test_subs{$testname} = sub { run_test($testinfo, $subs_count, $loop_count) };
-}
-
-printf "Profiler performance using perl %8s %s (%s %s %s)\n",
- $], $Config{archname},
- $Config{gccversion} ? 'gcc' : $Config{cc},
- (split / /, $Config{gccversion}||$Config{ccversion}||'')[0]||'',
- $Config{optimize};
-printf "NYTProf is $INC{'Devel/NYTProf/Data.pm'}\n";
-
-cmpthese(4, \%test_subs, 'nop');
-
-for my $testname (sort keys %test_subs) {
- my $testinfo = $tests{$testname};
- if ($testinfo->{datafile}) {
- printf "%10s: %6dKB %s\n",
- $testname, (-s $testinfo->{datafile})/1024, $testinfo->{datafile};
- unlink $testinfo->{datafile};
- }
-}
-
-exit 0;
-
-sub run_test {
- my($testinfo, $subs_count, $loop_count) = @_;
-
- my $env = $testinfo->{env};
- local $ENV{$env->[0]} = $env->[1] if $env;
-
- my $cmd = "perl $testinfo->{perlargs} $test_script $subs_count $loop_count";
- system($cmd) == 0;
-}
@@ -0,0 +1,360 @@
+#!/usr/bin/perl -w
+#
+# flamegraph.pl flame stack grapher.
+#
+# This takes stack samples and renders a call graph, allowing hot functions
+# and codepaths to be quickly identified.
+#
+# USAGE: ./flamegraph.pl input.txt > graph.svg
+#
+# grep funcA input.txt | ./flamegraph.pl > graph.svg
+#
+# The input is stack frames and sample counts formatted as single lines. Each
+# frame in the stack is semicolon separated, with a space and count at the end
+# of the line. These can be generated using DTrace with stackcollapse.pl.
+#
+# The output graph shows relative presence of functions in stack samples. The
+# ordering on the x-axis has no meaning; since the data is samples, time order
+# of events is not known. The order used sorts function names alphabetically.
+#
+# HISTORY
+#
+# This was inspired by Neelakanth Nadgir's excellent function_call_graph.rb
+# program, which visualized function entry and return trace events. As Neel
+# wrote: "The output displayed is inspired by Roch's CallStackAnalyzer which
+# was in turn inspired by the work on vftrace by Jan Boerhout". See:
+# https://blogs.oracle.com/realneel/entry/visualizing_callstacks_via_dtrace_and
+#
+# Copyright 2011 Joyent, Inc. All rights reserved.
+# Copyright 2011 Brendan Gregg. All rights reserved.
+#
+# CDDL HEADER START
+#
+# The contents of this file are subject to the terms of the
+# Common Development and Distribution License (the "License").
+# You may not use this file except in compliance with the License.
+#
+# You can obtain a copy of the license at usr/src/OPENSOLARIS.LICENSE
+# or http://opensource.org/licenses/CDDL-1.0.
+# See the License for the specific language governing permissions
+# and limitations under the License.
+#
+# When distributing Covered Code, include this CDDL HEADER in each
+# file and include the License file at usr/src/OPENSOLARIS.LICENSE.
+# If applicable, add the following below this CDDL HEADER, with the
+# fields enclosed by brackets "[]" replaced with your own identifying
+# information: Portions Copyright [yyyy] [name of copyright owner]
+#
+# CDDL HEADER END
+#
+# 17-Mar-2013 Tim Bunce Added options and more tunables.
+# 15-Dec-2011 Dave Pacheco Support for frames with whitespace.
+# 10-Sep-2011 Brendan Gregg Created this.
+
+use strict;
+
+use Getopt::Long;
+
+# tunables
+my $fonttype = "Verdana";
+my $imagewidth = 1200; # max width, pixels
+my $frameheight = 16; # max height is dynamic
+my $fontsize = 12; # base text size
+my $fontwidth = 0.55; # avg width relative to fontsize
+my $minwidth = 0.1; # min function width, pixels
+my $titletext = "Flame Graph"; # centered heading
+my $nametype = "Function:"; # what are the names in the data?
+my $countname = "samples"; # what are the counts in the data?
+my $nameattrfile; # file holding function attributes
+my $timemax; # (override the) sum of the counts
+my $factor = 1; # factor to scale counts by
+
+GetOptions(
+ 'fonttype=s' => \$fonttype,
+ 'width=i' => \$imagewidth,
+ 'height=i' => \$frameheight,
+ 'fontsize=f' => \$fontsize,
+ 'fontwidth=f' => \$fontwidth,
+ 'minwidth=f' => \$minwidth,
+ 'title=s' => \$titletext,
+ 'nametype=s' => \$nametype,
+ 'countname=s' => \$countname,
+ 'nameattr=s' => \$nameattrfile,
+ 'total=s' => \$timemax,
+ 'factor=f' => \$factor,
+) or exit 1;
+
+
+# internals
+my $ypad1 = $fontsize * 4; # pad top, include title
+my $ypad2 = $fontsize * 2 + 10; # pad bottom, include labels
+my $xpad = 10; # pad left and right
+my $depthmax = 0;
+my %Events;
+my %nameattr;
+
+if ($nameattrfile) {
+ # The name-attribute file format is a function name followed by a tab then
+ # a sequence of tab separated name=value pairs.
+ open my $attrfh, $nameattrfile or die "Can't read $nameattrfile: $!\n";
+ while (<$attrfh>) {
+ chomp;
+ my ($funcname, $attrstr) = split /\t/, $_, 2;
+ die "Invalid format in $nameattrfile" unless defined $attrstr;
+ $nameattr{$funcname} = { map { split /=/, $_, 2 } split /\t/, $attrstr };
+ }
+}
+
+# SVG functions
+{ package SVG;
+ sub new {
+ my $class = shift;
+ my $self = {};
+ bless ($self, $class);
+ return $self;
+ }
+
+ sub header {
+ my ($self, $w, $h) = @_;
+ $self->{svg} .= <<SVG;
+<?xml version="1.0" standalone="no"?>
+<!DOCTYPE svg PUBLIC "-//W3C//DTD SVG 1.1//EN" "http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd">
+<svg version="1.1" width="$w" height="$h" onload="init(evt)" viewBox="0 0 $w $h" xmlns="http://www.w3.org/2000/svg" xmlns:xlink="http://www.w3.org/1999/xlink">
+SVG
+ }
+
+ sub include {
+ my ($self, $content) = @_;
+ $self->{svg} .= $content;
+ }
+
+ sub colorAllocate {
+ my ($self, $r, $g, $b) = @_;
+ return "rgb($r,$g,$b)";
+ }
+
+ sub group_start {
+ my ($self, $attr) = @_;
+
+ my @g_attr = map {
+ exists $attr->{$_} ? sprintf(qq/$_="%s"/, $attr->{$_}) : ()
+ } qw(class style onmouseover onmouseout);
+ push @g_attr, $attr->{g_extra} if $attr->{g_extra};
+ $self->{svg} .= sprintf qq/<g %s>\n/, join(' ', @g_attr);
+
+ $self->{svg} .= sprintf qq/<title>%s<\/title>/, $attr->{title}
+ if $attr->{title}; # should be first element within g container
+
+ if ($attr->{href}) {
+ my @a_attr;
+ push @a_attr, sprintf qq/xlink:href="%s"/, $attr->{href} if $attr->{href};
+ # default target=_top else links will open within SVG <object>
+ push @a_attr, sprintf qq/target="%s"/, $attr->{target} || "_top";
+ push @a_attr, $attr->{a_extra} if $attr->{a_extra};
+ $self->{svg} .= sprintf qq/<a %s>/, join(' ', @a_attr);
+ }
+ }
+
+ sub group_end {
+ my ($self, $attr) = @_;
+ $self->{svg} .= qq/<\/a>\n/ if $attr->{href};
+ $self->{svg} .= qq/<\/g>\n/;
+ }
+
+ sub filledRectangle {
+ my ($self, $x1, $y1, $x2, $y2, $fill, $extra) = @_;
+ $x1 = sprintf "%0.1f", $x1;
+ $x2 = sprintf "%0.1f", $x2;
+ my $w = sprintf "%0.1f", $x2 - $x1;
+ my $h = sprintf "%0.1f", $y2 - $y1;
+ $extra = defined $extra ? $extra : "";
+ $self->{svg} .= qq/<rect x="$x1" y="$y1" width="$w" height="$h" fill="$fill" $extra \/>\n/;
+ }
+
+ sub stringTTF {
+ my ($self, $color, $font, $size, $angle, $x, $y, $str, $loc, $extra) = @_;
+ $loc = defined $loc ? $loc : "left";
+ $extra = defined $extra ? $extra : "";
+ $self->{svg} .= qq/<text text-anchor="$loc" x="$x" y="$y" font-size="$size" font-family="$font" fill="$color" $extra >$str<\/text>\n/;
+ }
+
+ sub svg {
+ my $self = shift;
+ return "$self->{svg}</svg>\n";
+ }
+ 1;
+}
+
+sub color {
+ my $type = shift;
+ if (defined $type and $type eq "hot") {
+ my $r = 205 + int(rand(50));
+ my $g = 0 + int(rand(230));
+ my $b = 0 + int(rand(55));
+ return "rgb($r,$g,$b)";
+ }
+ return "rgb(0,0,0)";
+}
+
+my %Node;
+my %Tmp;
+
+sub flow {
+ my ($last, $this, $v) = @_;
+
+ my $len_a = @$last - 1;
+ my $len_b = @$this - 1;
+
+ my $i = 0;
+ my $len_same;
+ for (; $i <= $len_a; $i++) {
+ last if $i > $len_b;
+ last if $last->[$i] ne $this->[$i];
+ }
+ $len_same = $i;
+
+ for ($i = $len_a; $i >= $len_same; $i--) {
+ my $k = "$last->[$i];$i";
+ # a unique ID is constructed from "func;depth;etime";
+ # func-depth isn't unique, it may be repeated later.
+ $Node{"$k;$v"}->{stime} = delete $Tmp{$k}->{stime};
+ delete $Tmp{$k};
+ }
+
+ for ($i = $len_same; $i <= $len_b; $i++) {
+ my $k = "$this->[$i];$i";
+ $Tmp{$k}->{stime} = $v;
+ }
+
+ return $this;
+}
+
+# Parse input
+my @Data = <>;
+my $last = [];
+my $time = 0;
+my $ignored = 0;
+foreach (sort @Data) {
+ chomp;
+ my ($stack, $samples) = (/^(.*)\s+(\d+(?:\.\d*)?)$/);
+ unless (defined $samples) {
+ ++$ignored;
+ next;
+ }
+ $stack =~ tr/<>/()/;
+ $last = flow($last, [ '', split ";", $stack ], $time);
+ $time += $samples;
+}
+flow($last, [], $time);
+warn "Ignored $ignored lines with invalid format\n" if $ignored;
+die "ERROR: No stack counts found\n" unless $time;
+
+if ($timemax and $timemax < $time) {
+ warn "Specified --total $timemax is less than actual total $time, so ignored\n"
+ if $timemax/$time > 0.02; # only warn is significant (e.g., not rounding etc)
+ undef $timemax;
+}
+$timemax ||= $time;
+
+my $widthpertime = ($imagewidth - 2 * $xpad) / $timemax;
+my $minwidth_time = $minwidth / $widthpertime;
+
+# prune blocks that are too narrow and determine max depth
+while (my ($id, $node) = each %Node) {
+ my ($func, $depth, $etime) = split ";", $id;
+ my $stime = $node->{stime};
+ die "missing start for $id" if not defined $stime;
+
+ if (($etime-$stime) < $minwidth_time) {
+ delete $Node{$id};
+ next;
+ }
+ $depthmax = $depth if $depth > $depthmax;
+}
+
+# Draw canvas
+my $imageheight = ($depthmax * $frameheight) + $ypad1 + $ypad2;
+my $im = SVG->new();
+$im->header($imagewidth, $imageheight);
+my $inc = <<INC;
+<defs >
+ <linearGradient id="background" y1="0" y2="1" x1="0" x2="0" >
+ <stop stop-color="#eeeeee" offset="5%" />
+ <stop stop-color="#eeeeb0" offset="95%" />
+ </linearGradient>
+</defs>
+<style type="text/css">
+ .func_g:hover { stroke:black; stroke-width:0.5; }
+</style>
+<script type="text/ecmascript">
+<![CDATA[
+ var details;
+ function init(evt) { details = document.getElementById("details").firstChild; }
+ function s(info) { details.nodeValue = "$nametype " + info; }
+ function c() { details.nodeValue = ' '; }
+]]>
+</script>
+INC
+$im->include($inc);
+$im->filledRectangle(0, 0, $imagewidth, $imageheight, 'url(#background)');
+my ($white, $black, $vvdgrey, $vdgrey) = (
+ $im->colorAllocate(255, 255, 255),
+ $im->colorAllocate(0, 0, 0),
+ $im->colorAllocate(40, 40, 40),
+ $im->colorAllocate(160, 160, 160),
+ );
+$im->stringTTF($black, $fonttype, $fontsize + 5, 0.0, int($imagewidth / 2), $fontsize * 2, $titletext, "middle");
+$im->stringTTF($black, $fonttype, $fontsize, 0.0, $xpad, $imageheight - ($ypad2 / 2), " ", "", 'id="details"');
+
+# Draw frames
+
+while (my ($id, $node) = each %Node) {
+ my ($func, $depth, $etime) = split ";", $id;
+ my $stime = $node->{stime};
+
+ $etime = $timemax if $func eq "" and $depth == 0;
+
+ my $x1 = $xpad + $stime * $widthpertime;
+ my $x2 = $xpad + $etime * $widthpertime;
+ my $y1 = $imageheight - $ypad2 - ($depth + 1) * $frameheight + 1;
+ my $y2 = $imageheight - $ypad2 - $depth * $frameheight;
+
+ my $samples = sprintf "%.0f", ($etime - $stime) * $factor;
+ (my $samples_txt = $samples) # add commas per perlfaq5
+ =~ s/(^[-+]?\d+?(?=(?>(?:\d{3})+)(?!\d))|\G\d{3}(?=\d))/$1,/g;
+
+ my $info;
+ if ($func eq "" and $depth == 0) {
+ $info = "all ($samples_txt $countname, 100%)";
+ } else {
+ my $pct = sprintf "%.2f", ((100 * $samples) / ($timemax * $factor));
+ my $escaped_func = $func;
+ $escaped_func =~ s/&/&/g;
+ $escaped_func =~ s/</</g;
+ $escaped_func =~ s/>/>/g;
+ $info = "$escaped_func ($samples_txt $countname, $pct%)";
+ }
+
+ my $nameattr = { %{ $nameattr{$func}||{} } }; # shallow clone
+ $nameattr->{class} ||= "func_g";
+ $nameattr->{onmouseover} ||= "s('".$info."')";
+ $nameattr->{onmouseout} ||= "c()";
+ $nameattr->{title} ||= $info;
+ $im->group_start($nameattr);
+
+ $im->filledRectangle($x1, $y1, $x2, $y2, color("hot"), 'rx="2" ry="2"');
+
+ my $chars = int( ($x2 - $x1) / ($fontsize * $fontwidth));
+ if ($chars >= 3) { # room for one char plus two dots
+ my $text = substr $func, 0, $chars;
+ substr($text, -2, 2) = ".." if $chars < length $func;
+ $text =~ s/&/&/g;
+ $text =~ s/</</g;
+ $text =~ s/>/>/g;
+ $im->stringTTF($black, $fonttype, $fontsize, 0.0, $x1 + 3, 3 + ($y1 + $y2) / 2, $text, "");
+ }
+
+ $im->group_end($nameattr);
+}
+
+print $im->svg;
@@ -0,0 +1,222 @@
+#!/usr/bin/perl
+##########################################################
+# This script is part of the Devel::NYTProf distribution
+#
+# Copyright, contact and other information can be found
+# at the bottom of this file, or by going to:
+# http://search.cpan.org/dist/Devel-NYTProf/
+#
+##########################################################
+
+use warnings;
+use strict;
+
+use Devel::NYTProf::Core;
+require Devel::NYTProf::Data;
+
+our $VERSION = '5.06';
+
+use Data::Dumper;
+use Getopt::Long;
+use Carp;
+
+GetOptions(
+ 'help|h' => \&usage,
+ 'verbose|v' => \my $opt_verbose,
+ 'calls!' => \my $opt_calls, # sum calls instead of time
+ 'debug|d' => \my $opt_debug,
+ 'stable' => \my $opt_stable, # used for testing (stability)
+) or usage();
+
+$opt_verbose++ if $opt_debug;
+$|++ if $opt_verbose;
+
+usage() unless @ARGV;
+
+
+# We're building a tree structure from a stream of "subroutine returned" events.
+# (We use these because the subroutine entry events don't have reliable
+# value for the subroutine name, and obviously don't have timings.)
+#
+# Building a call tree from return events is a little tricky because they don't
+# appear in natural order. The code can return from a call at any depth
+# deeper than the last seen depth.
+#
+my $root = {};
+my @stack = ($root);
+my $total_in = 0;
+
+my $last_subid = 0;
+my %subname2id;
+
+my $sibling_avoided = 0;
+my $siblings_max = 0;
+
+my %option;
+my %attribute;
+
+
+my $callbacks = {
+
+ OPTION => sub { my (undef, $k, $v) = @_; $option{$k} = $v },
+ ATTRIBUTE => sub { my (undef, $k, $v) = @_; $attribute{$k} = $v },
+
+ SUB_ENTRY => sub {
+ my (undef, $fid, $line) = @_;
+ warn "> at $fid:$line\n" if $opt_verbose;
+ },
+
+ SUB_RETURN => sub {
+ # $retn_depth is the call stack depth of the sub call we're returning from
+ my (undef, $retn_depth, undef, $excl_time, $subname) = @_;
+
+ warn sprintf "< %2d %-10s %s (stack %d)\n", $retn_depth, $subname, $excl_time, scalar @stack
+ if $opt_verbose;
+
+ my $v = ($opt_calls) ? 1 : $excl_time;
+ $total_in += $v;
+
+ # normalize and merge sibling string evals by setting eval seqn to 0
+ $subname =~ s/\( (\w*eval)\s\d+ \) (?= \[ .+? :\d+ \] )/($1 0)/gx;
+ # assign an id to the subname for memory efficiency
+ my $subid = $subname2id{$subname} ||= ++$last_subid;
+
+ # Either...
+ # a) we're returning from some sub deeper than the current stack
+ # in which case we push unnamed sub calls ("0") onto the stack
+ # till we get to the right depth, then fall through to:
+ # b) we're returning from the sub on top of the stack.
+
+ while (@stack <= $retn_depth) { # build out the tree if needed
+ my $crnt_node = $stack[-1];
+ die "panic" if $crnt_node->{0};
+ push @stack, ($crnt_node->{0} = {});
+ }
+
+ # top of stack: sub we're returning from
+ # next on stack: sub that was the caller
+ my $sub_return = pop @stack;
+ my $sub_caller = $stack[-1] || die "panic";
+
+ die "panic" unless $sub_return == $sub_caller->{0};
+ delete $sub_caller->{0} or die "panic"; # == $sub_return
+
+ # {
+ # 0 - as-yet un-returned subs
+ # 'v' - cumulative excl_time in this sub
+ # $subid1 => {...} # calls to $subid1 made by this sub
+ # $subid2 => {...}
+ # }
+
+ $sub_return->{v} += $v;
+ _merge_sub_return_into_caller($sub_caller->{$subid} ||= {}, $sub_return);
+ },
+};
+
+
+foreach my $input (@ARGV) {
+ warn "Reading $input...\n" if $opt_verbose;
+ Devel::NYTProf::Data->new({
+ filename => $input,
+ quiet => 1,
+ callback => $callbacks
+ });
+}
+
+
+# transform tree into a simple hash of call paths "subid;subid;subid" => value
+my %subidpaths;
+visit_node($root, [], sub {
+ my ($node, $path) = @_;
+ $subidpaths{ join(";", @$path) } += $node->{v}
+ if @$path;
+});
+
+# output the totals without scaling, so they're in ticks_per_sec units
+my $val_scale_factor = 1; # ($opt_calls) ? 1 : 1_000_000 / $attribute{ticks_per_sec};
+my $val_format = ($opt_calls || $val_scale_factor==1) ? "%s %d\n" : "%s %.1f\n";
+my $total_out = 0;
+
+# ensure subnames don't contain ";" or " "
+tr/; /??/ for values %subname2id;
+my %subid2name = reverse %subname2id;
+
+# output the subidpaths hash using subroutine names
+my @subidpaths = keys %subidpaths;
+@subidpaths = sort @subidpaths if $opt_stable;
+for my $subidpath (@subidpaths) {
+ my @path = map { $subid2name{$_} } split ";", $subidpath;
+ my $path = join(";", @path);
+ my $v = $subidpaths{$subidpath};
+ printf $val_format, join(";", @path), $v * $val_scale_factor;
+ $total_out += $v;
+}
+
+warn "nytprofcalls inconsistency: total in $total_in doesn't match total out $total_out\n"
+ if $total_in != $total_out;
+
+warn sprintf "Done Total $total_in (siblings: avoided $sibling_avoided, max $siblings_max)\n"
+ if $opt_verbose;
+
+exit 0;
+
+
+sub _merge_sub_return_into_caller {
+ my ($dest, $new, $recurse) = @_;
+ $dest->{v} += delete $new->{v};
+ while ( my ($new_called_subid, $new_called_node) = each %$new ) {
+ if ($dest->{$new_called_subid}) {
+ _merge_sub_return_into_caller($dest->{$new_called_subid}, $new_called_node);
+ }
+ else {
+ $dest->{$new_called_subid} = $new_called_node;
+ }
+ }
+}
+
+
+sub visit_node { # depth first
+ my $node = shift;
+ my $path = shift;
+ my $sub = shift;
+
+ warn "visit_node: @{[ %$node ]}\n" if $opt_debug;
+
+ push @$path, undef;
+ while ( my ($subid, $childnode) = each %$node) {
+ next if $subid eq 'v';
+ die "panic" if $subid eq '0';
+
+ $path->[-1] = $subid;
+ warn "node @$path: @{[ %$childnode ]}\n" if $opt_debug;
+ visit_node($childnode, $path, $sub);
+ }
+ pop @$path;
+
+ $sub->($node, $path);
+
+ %$node = (); # reclaim memory as we go
+}
+
+
+sub usage {
+ print <<END;
+usage: [perl] nytprofcalls [opts] nytprof-file [...]
+
+ --help, -h Print this message
+ --verbose, -v Be more verbose
+
+This script of part of the Devel::NYTProf distribution.
+See https://metacpan.org/release/Devel-NYTProf for details and copyright.
+END
+ exit 0;
+}
+
+__END__
+
+=head1 NAME
+
+nytprofcalls - experimental
+
+=cut
+# vim:ts=8:sw=4:et
@@ -5,8 +5,6 @@
## See http://search.cpan.org/dist/Devel-NYTProf/
##
##########################################################
-# $Id: /mirror/devel-nytprof/bin/nytprofhtml 13295 2009-04-06T20:34:49.946854Z tim.bunce $
-###########################################################
use warnings;
use strict;
@@ -7,8 +7,6 @@
# http://search.cpan.org/dist/Devel-NYTProf/
#
##########################################################
-# $Id$
-##########################################################
use warnings;
use strict;
@@ -50,7 +48,7 @@ if (!-r $opt{file}) {
die "$0: Unable to access $opt{file}\n";
}
-# handle handle output location
+# handle output location
if (!-e $opt{out}) {
# will be created
@@ -131,7 +129,7 @@ __END__
=head1 NAME
-nytprofcsv - L<Devel::NYTProf::Reader> CSV format implementation
+nytprofcsv - (DEPRECATED) L<Devel::NYTProf::Reader> CSV format implementation
=head1 SYNOPSIS
@@ -141,6 +139,10 @@ nytprofcsv - L<Devel::NYTProf::Reader> CSV format implementation
nytprofcsv
Generating CSV Output...
+=head1 NOTE
+
+B<nytprofcsv is deprecated and will be removed in a future release.>
+
=head1 HISTORY
A bit of history and a shameless plug...
@@ -195,8 +197,6 @@ Print the help message
0,0,0,#--------------------------------------------------------------------
0,0,0,# My New Source File!
0,0,0,#--------------------------------------------------------------------
- 0,0,0,# $Id$
- 0,0,0,#--------------------------------------------------------------------
0,0,0,
0,0,0,package NYT::Feeds::Util;
0.00047,3,0.000156666666666667,use Date::Calc qw(Add_Delta_DHMS);
@@ -59,7 +59,7 @@ use Devel::NYTProf::Util qw(
);
use Devel::NYTProf::Constants qw(NYTP_SCi_CALLING_SUB);
-our $VERSION = '4.23';
+our $VERSION = '5.06';
if ($VERSION != $Devel::NYTProf::Core::VERSION) {
die "$0 version '$VERSION' doesn't match version '$Devel::NYTProf::Core::VERSION' of $INC{'Devel/NYTProf/Core.pm'}\n";
@@ -88,6 +88,7 @@ GetOptions(
'open!' => \my $opt_open,
'help|h' => sub { exit usage() },
'minimal|m!'=> \my $opt_minimal,
+ 'flame!' => \(my $opt_flame = 1),
'mergeevals!'=> \(my $opt_mergeevals = 1),
'profself!' => sub { }, # handled in BEGIN above
'debug!' => \my $opt_debug,
@@ -104,6 +105,7 @@ usage: [perl] nytprofhtml [opts]
--delete, -d Delete any old report files in <dir> first
--open Open the generated report in a web browser
--lib <lib>, -l <lib> Add <lib> to the beginning of \@INC
+ --no-flame Disable flame graph (and call stacks processing)
--minimal, -m Don't generate graphviz .dot files or block/sub-level reports
--no-mergeevals Disable merging of string evals
--help, -h Print this message
@@ -115,7 +117,7 @@ END
}
-# handle handle output location
+# handle output location
if (!-e $opt_out) {
# will be created
}
@@ -243,7 +245,7 @@ modules.</p>
</div>\n}
}
-);
+) if $] < 5.017008;
$reporter->set_param(
'merged_fids',
@@ -757,10 +759,12 @@ sub output_index_page {
my $summary = sprintf "Profile of %s for %s (of %s),", $application,
fmt_time($profile->{attribute}{profiler_active}),
fmt_time($profile->{attribute}{profiler_duration});
- $summary .= sprintf " executing %d statements",
+ $summary .= " executing";
+ $summary .= sprintf " %d statements and",
$profile->{attribute}{total_stmts_measured}
- -$profile->{attribute}{total_stmts_discounted};
- $summary .= sprintf " and %d subroutine calls",
+ -$profile->{attribute}{total_stmts_discounted}
+ if $profile->{option}{stmts};
+ $summary .= sprintf " %d subroutine calls",
$profile->{attribute}{total_sub_calls};
$summary .= sprintf " in %d source files",
@all_fileinfos - $eval_fileinfos;
@@ -780,6 +784,50 @@ sub output_index_page {
print $fh "</select></form></div>\n";
}
+ my $call_stacks_file = "all_stacks_by_time.calls";
+ my $call_stacks_svg = "all_stacks_by_time.svg";
+ if ($profile->{option}{calls} && $opt_flame) {
+ my $mk_flamegraph = sub {
+
+ warn sprintf "Extracting subroutine call data%s ...\n",
+ ($profile->{attribute}{total_sub_calls} <= 1_000_000) ? ""
+ : " (there were $profile->{attribute}{total_sub_calls} of them, so this may take some time)";
+ system("nytprofcalls $opt_file > $opt_out/$call_stacks_file") == 0
+ or die "Generating $opt_out/$call_stacks_file failed\n";
+
+ my %subname_subinfo_map = %{ $profile->subname_subinfo_map };
+ warn "Extracting subroutine links\n";
+ my $subattr = "$opt_out/flamegraph_subattr.txt";
+ open my $subattrfh, ">", $subattr
+ or die "Error creating $subattr: $!\n";
+ while ( my ($subname, $si) = each %subname_subinfo_map ) {
+ next unless $si->incl_time;
+ print $subattrfh join("\t", $subname,
+ q{href=}.$reporter->url_for_sub($subname),
+ )."\n";
+ }
+ close $subattrfh or die "Error writing $subattr: $!\n";
+
+ warn "Generating subroutine stack flame graph ...\n";
+ # factor to scale the values to microseconds
+ my $factor = 1_000_000 / $profile->{attribute}{ticks_per_sec};
+ # total (width) for flamegraph is profiler_active in ticks
+ my $run_us = $profile->{attribute}{profiler_active} * $profile->{attribute}{ticks_per_sec};
+ my $extension = $^O eq "MSWin32" ? "" : ".pl";
+ my $fg_cmd = "flamegraph$extension --nametype=sub --countname=microseconds";
+ system("$fg_cmd --factor=$factor --nameattr=$subattr --total=$run_us $opt_out/$call_stacks_file > $opt_out/$call_stacks_svg") == 0
+ or die "Generating $opt_out/$call_stacks_svg failed\n";
+
+ print $fh qq{<div class="flamegraph">\n};
+ print $fh qq{<object data="$call_stacks_svg" width="1200" type="image/svg+xml" >SVG not supported</object>\n};
+ print $fh qq{<p>The <a href="http://dtrace.org/blogs/brendan/2011/12/16/flame-graphs/">Flame Graph</a> above is a visualization of the time spent in <em>distinct call stacks</em>. The colors and x-axis position are not meaningful.</p>\n};
+ print $fh qq{</div>\n};
+ 1;
+ };
+ eval { $mk_flamegraph->() }
+ or warn $@;
+ }
+
# Show top subs across all files
my $max_subs = 15; # keep it less than a page so users can see the file table
my $all_subs = keys %{$profile->{sub_subinfo}};
@@ -1356,7 +1404,10 @@ sub output_file_table {
$eval_time = sum(map { $_->sum_of_stmts_time } @has_evals);
}
# is this file one where we sawampersand (or contains an eval that is)?
- if ($sawampersand_fi && $fi == ($sawampersand_fi->outer || $sawampersand_fi)) {
+ if ($sawampersand_fi
+ && $] < 5.017008
+ && $fi == ($sawampersand_fi->outer || $sawampersand_fi)
+ ) {
my $in_eval = ($fi == $sawampersand_fi)
? 'here'
: sprintf q{<a %s>in eval here</a>}, $reporter->href_for_file($sawampersand_fi, undef, 'line');
@@ -1557,6 +1608,7 @@ This file was generated by Devel::NYTProf version $Devel::NYTProf::Core::VERSION
<head>
<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<meta http-equiv="Content-Language" content="en-us" />
+ <meta name="robots" content="noindex,nofollow" />
<title>$title</title>
EOD
@@ -1587,7 +1639,7 @@ EOD
// console.log(orig);
var val = orig.replace(/ns/,'');
if (val != orig) { return val / (1000*1000*1000); }
- val = orig.replace(/[µ\xB5]s/,''); /* allow for browser encoding XXX use µ ? */
+ val = orig.replace(/[µ\xB5]s/,''); /* micro */
if (val != orig) { return val / (1000*1000); }
val = orig.replace(/ms/,'');
if (val != orig) { return val / (1000); }
@@ -1855,6 +1907,10 @@ pre,.s {
padding-top: 5px; color: gray;
}
+.flamegraph {
+ margin: 20px 0px;
+}
+
EOD
}
@@ -1909,6 +1965,16 @@ Make your web browser visit the report after it has been generated.
If this doesn't work well for you, try installing the L<Browser::Open> module.
+=item -m, --minimal
+
+Don't generate graphviz .dot files or block/sub-level reports.
+
+=item --no-flame
+
+Disable generation of the framegraph on the index page.
+Also disables calculation of distinct call stacks that are used to produce the
+flamegraph.
+
=item -h, --help
Print the help message.
@@ -7,8 +7,6 @@
# http://search.cpan.org/dist/Devel-NYTProf/
#
##########################################################
-# $Id$
-##########################################################
use warnings;
use strict;
@@ -18,7 +16,7 @@ require Devel::NYTProf::FileHandle;
require Devel::NYTProf::Data;
use List::Util qw(min sum);
-our $VERSION = '4.23';
+our $VERSION = '5.06';
if ($VERSION != $Devel::NYTProf::Core::VERSION) {
die "$0 version '$VERSION' doesn't match version '$Devel::NYTProf::Core::VERSION' of $INC{'Devel/NYTProf/Core.pm'}\n";
@@ -82,9 +80,11 @@ my %attr_should_be_identical = map {$_, 1} qw(
PL_perldb clock_id nv_size perl_version ticks_per_sec xs_version
);
+
# Effectively, these are global variables. Sorry.
our $input;
our %attributes;
+our %options;
our $deflating;
my %dispatcher =
@@ -112,6 +112,7 @@ my %dispatcher =
return if $text =~ /\ACompressed at level \d with zlib [0-9.]+\z/;
$out->write_comment($text)
},
+
ATTRIBUTE => sub {
my (undef, $key, $value) = @_;
if ($attr_should_be_identical{$key}) {
@@ -128,6 +129,19 @@ my %dispatcher =
}
},
+ OPTION => sub {
+ my (undef, $key, $value) = @_;
+
+ if (exists $options{$key}) {
+ if ($options{$key} ne $value) {
+ warn("Option '$key' has value '$value' in $input which differs from the previous value '$options{$key}'; this implies inconsistent profiles and thus garbage results\n");
+ }
+ } else {
+ $options{$key} = $value;
+ $out->write_option($key, $value);
+ }
+ },
+
START_DEFLATE => sub {
if (!$deflating && $out->can('start_deflate_write_tag_comment')) {
$out->start_deflate_write_tag_comment;
@@ -193,6 +207,18 @@ my %dispatcher =
};
}
},
+
+ SUB_ENTRY => sub {
+ my (undef, $fid, $line) = @_;
+ confess("No mapping for $fid") unless defined $fids{$fid};
+ $fid = $fids{$fid};
+ $out->write_call_entry($fid, $line);
+ },
+ SUB_RETURN => sub {
+ my (undef, $retn_depth, $incl_time, $excl_time, $subname) = @_;
+ $out->write_call_return($retn_depth, $subname, $incl_time, $excl_time);
+ },
+
SRC_LINE => sub {
my (undef, $fid, $line, $text) = @_;
confess("No mapping for $fid") unless defined $fids{$fid};
@@ -202,13 +228,14 @@ my %dispatcher =
$fid = $mapped_fid if defined $mapped_fid;
$out->write_src_line($fid, $line, $text);
},
- );
+);
foreach $input (@ARGV) {
print "Reading $input...\n" if $opt_verbose;
@pending_fids = ();
%pending_subs = ();
+ # first pass
Devel::NYTProf::Data->new({filename => $input, callback => {
NEW_FID => sub {
my (undef, $fid, $eval_fid, $eval_line, $flags, $size, $mtime, $name) = @_;
@@ -279,7 +306,7 @@ foreach $input (@ARGV) {
# to the sub are collated.
# Have to use the mapped fid as the key to this hash, as
- # only the mapped fids are are unique
+ # only the mapped fids are unique
my $mapped_fid = $fids{$fid};
$map_range{$mapped_fid}[$_] = $folded
for $first_line .. $last_line;
@@ -294,6 +321,7 @@ foreach $input (@ARGV) {
}
}});
+ # second pass
print "Re-reading $input...\n" if $opt_verbose;
Devel::NYTProf::Data->new({filename => $input, callback => \%dispatcher});
}
@@ -340,12 +368,14 @@ foreach my $key (sort grep {!$attr_should_be_identical{$_}} keys %attributes) {
$out->write_attribute($key, $values[0]);
}
else {
- warn sprintf "Unknown attribute %s has %d values passed through unmerged\n",
- $key, scalar @values;
+ warn sprintf "Attribute %s has %d distinct values passed through unmerged\n",
+ $key, scalar @values
+ if @values > 1;
$out->write_attribute($key, $_) foreach @values;
}
}
+
print "Done.\n" if $opt_verbose;
exit 0;
@@ -1,125 +0,0 @@
-#! /usr/bin/env perl
-# vim: ts=8 sw=4 sts=4 expandtab:
-##########################################################
-## This script is part of the Devel::NYTProf distribution
-##
-## Copyright, contact and other information can be found
-## at the bottom of this file, or by going to:
-## http://search.cpan.org/perldoc?Devel::NYTProf
-##
-###########################################################
-## $Id: benchmark.pl 322 2008-07-15 04:33:35Z tim.bunce $
-###########################################################
-use warnings;
-use strict;
-
-use Carp;
-use Config;
-use Getopt::Long;
-use Benchmark qw(:hireswallclock timethese cmpthese);
-use Devel::NYTProf::Data; # just to print path
-
-GetOptions(
- 'v|verbose' => \my $opt_verbose,
-) or exit 1;
-
-my $regex = shift;
-
-my $subs_count = shift || 2000;
-my $loop_count = shift || 1000;
-
-# simple benchmark script to measure profiling overhead
-my $test_script = "benchmark_code.pl";
-open my $fh, ">", $test_script or die "Can't write to $test_script: $!\n";
-print $fh q{
- my $subs_count = shift || die "No subs count";
- my $loop_count = shift || die "No loop count";
- sub foo {
- my $loop = shift;
- my $a = 0;
- while ($loop-- > 0) { ++$a; ++$a; ++$a; }
- }
- while ($subs_count-- > 0) {
- foo($loop_count)
- }
-};
-close $fh or die "Error writing to $test_script: $!\n";
-END { unlink $test_script };
-
-
-my %tests = (
- baseline => {
- perlargs => '',
- },
- dprof => {
- perlargs => '-d:DProf',
- datafile => 'tmon.out',
- },
- fastprof => {
- perlargs => '-MDevel::FastProf',
- datafile => 'fastprof.out',
- },
- profit => {
- perlargs => '-MDevel::Profit',
- datafile => 'profit.out',
- },
- nytprof_o => {
- env => [ NYTPROF => 'use_db_sub=0:file=nytprof_o.out' ],
- perlargs => '-d:NYTProf',
- datafile => 'nytprof_o.out',
- },
- nytprof_s => {
- env => [ NYTPROF => 'use_db_sub=1:file=nytprof_s.out' ],
- perlargs => '-d:NYTProf',
- datafile => 'nytprof_s.out',
- },
- nytprof_ob => {
- env => [ NYTPROF => 'blocks:file=nytprof_ob.out' ],
- perlargs => '-d:NYTProf',
- datafile => 'nytprof_ob.out',
- },
-);
-
-my %test_subs;
-while ( my ($testname, $testinfo) = each %tests ) {
- if ($regex && $testname ne 'baseline' && $testname !~ m/$regex/o) {
- warn "Skipped $testname\n";
- next;
- }
- if (!run_test($testinfo, 1, 1)) {
- warn "Can't run $testname profiler - skipped\n";
- next;
- }
- $testinfo->{testname} = $testname;
- $test_subs{$testname} = sub { run_test($testinfo, $subs_count, $loop_count) };
-}
-
-printf "Profiler performance using perl %8s %s (%s %s %s)\n",
- $], $Config{archname},
- $Config{gccversion} ? 'gcc' : $Config{cc},
- (split / /, $Config{gccversion}||$Config{ccversion}||'')[0]||'',
- $Config{optimize};
-printf "NYTProf is $INC{'Devel/NYTProf/Data.pm'}\n";
-
-cmpthese(4, \%test_subs, 'nop');
-
-for my $testname (sort keys %test_subs) {
- my $testinfo = $tests{$testname};
- if ($testinfo->{datafile}) {
- printf "%10s: %6dKB %s\n",
- $testname, (-s $testinfo->{datafile})/1024, $testinfo->{datafile};
- unlink $testinfo->{datafile};
- }
-}
-
-exit 0;
-
-sub run_test {
- my($testinfo, $subs_count, $loop_count) = @_;
-
- my $env = $testinfo->{env};
- local $ENV{$env->[0]} = $env->[1] if $env;
-
- my $cmd = "perl $testinfo->{perlargs} $test_script $subs_count $loop_count";
- system($cmd) == 0;
-}
@@ -7,8 +7,6 @@
# http://search.cpan.org/dist/Devel-NYTProf/
#
###########################################################
-# $Id$
-###########################################################
package Devel::NYTProf::Apache;
our $VERSION = '4.00';
@@ -7,14 +7,12 @@
# http://search.cpan.org/dist/Devel-NYTProf/
#
###########################################################
-# $Id$
-###########################################################
package Devel::NYTProf::Core;
use XSLoader;
-our $VERSION = '4.23'; # increment with XS changes too
+our $VERSION = '5.06'; # increment with XS changes too
XSLoader::load('Devel::NYTProf', $VERSION);
@@ -7,8 +7,6 @@
# http://search.cpan.org/dist/Devel-NYTProf/
#
###########################################################
-# $Id$
-###########################################################
package Devel::NYTProf::Data;
=head1 NAME
@@ -223,6 +221,10 @@ sub attributes {
return shift->{attribute} || {};
}
+sub options {
+ return shift->{option} || {};
+}
+
sub subname_subinfo_map {
return { %{ shift->{sub_subinfo} } }; # shallow copy
}
@@ -309,7 +311,7 @@ sub packages_at_depth_subinfo {
my @parts = split /::/, $fullpkgname; # drops empty trailing part
# accumulate @$subinfos for the full package name
- # and also for each succesive truncation of the package name
+ # and also for each successive truncation of the package name
for (my $depth; $depth = @parts; pop @parts) {
my $pkgname = join('::', @parts, '');
@@ -396,7 +398,7 @@ sub inc {
separator => "",
} );
-Writes the profile data in a reasonably human friendly format to the sepcified
+Writes the profile data in a reasonably human friendly format to the specified
C<filehandle> (default STDOUT).
For non-trivial profiles the output can be very large. As a guide, there'll be
@@ -408,7 +410,7 @@ The types of data present can depend on the options used when profiling.
If C<separator> is true then instead of whitespace, each item of data is
indented with the I<path> through the structure with C<separator> used to
-separarate the elements of the path.
+separate the elements of the path.
This format is especially useful for grep'ing and diff'ing.
=cut
@@ -587,7 +589,12 @@ filenames: eval sequence numbers, like "(re_eval 2)" are changed to 0
sub normalize_variables {
- my $self = shift;
+ my ($self, $normalize_options) = @_;
+
+ if ($normalize_options) {
+ %{ $self->options } = ();
+ }
+
my $attributes = $self->attributes;
for my $attr (qw(
@@ -172,7 +172,7 @@ hashes with file id integers as keys and FileInfo objects as values.
sub evals_by_line {
my ($self) = @_;
- # find all fids that have have this fid as an eval_fid
+ # find all fids that have this fid as an eval_fid
# { line => { fid_of_eval_at_line => $fi, ... } }
my %evals_by_line;
@@ -144,6 +144,12 @@ The path to the program that ran; same as C<$0> in the program itself.
=back
+=item OPTION => $key, $value
+
+This chunk type is repeated at the beginning of the file and used to record the
+options, e.g. set via the NYTPROF env var, that were effect during the
+profiling run.
+
=item START_DEFLATE
This chunk just say that from now on all chunks have been compressed
@@ -7,8 +7,6 @@
## http://search.cpan.org/dist/Devel-NYTProf/
##
###########################################################
-## $Id$
-###########################################################
package Devel::NYTProf::Reader;
our $VERSION = '4.06';
@@ -552,15 +550,15 @@ sub _generate_report {
sub url_for_file {
my ($self, $file, $anchor, $level) = @_;
confess "No file specified" unless $file;
+ $level ||= '';
- my $fi = $self->{profile}->fileinfo_of($file);
- #return "" if $fi->is_fake;
- $level = 'line' if $fi->is_eval;
+ my $url = $self->{_cache}{"url_for_file,$file,$level"} ||= do {
+ my $fi = $self->{profile}->fileinfo_of($file);
+ $level = 'line' if $fi->is_eval;
+ $self->fname_for_fileinfo($fi, $level) . ".html";
+ };
- my $url = $self->fname_for_fileinfo($fi, $level);
- $url .= '.html';
$url .= "#$anchor" if defined $anchor;
-
return $url;
}
@@ -9,8 +9,6 @@ package Devel::NYTProf::Run;
# http://search.cpan.org/dist/Devel-NYTProf/
#
###########################################################
-# $Id: Util.pm 809 2009-07-07 13:24:31Z tim.bunce $
-###########################################################
=head1 NAME
@@ -61,7 +59,7 @@ sub perl_command_words {
# croaks on failure to execute
# carps, not croak, if process has non-zero exit status
-# Devel::NYTProf::Data->new may croak, e.g., if data trucated
+# Devel::NYTProf::Data->new may croak, e.g., if data truncated
sub profile_this {
my %opt = @_;
@@ -7,8 +7,6 @@
# http://search.cpan.org/dist/Devel-NYTProf/
#
###########################################################
-# $Id$
-###########################################################
package Devel::NYTProf::Util;
=head1 NAME
@@ -27,6 +25,8 @@ B<Note:> The documentation for this module is currently incomplete and out of da
=head1 FUNCTIONS
+=encoding ISO8859-1
+
=cut
@@ -181,7 +181,7 @@ sub fmt_time {
return sprintf $fmt_time_opt, $sec if $fmt_time_opt;
return sprintf "%$width.0fs", 0 unless $sec;
return sprintf "%$width.0fns", $sec * 1e9 if $sec < 1e-6;
- return sprintf "%$width.0fµs", $sec * 1e6 if $sec < 1e-3;
+ return sprintf "%$width.0fµs", $sec * 1e6 if $sec < 1e-3;
return sprintf "%$width.*fms", 3 - length(int($sec * 1e3)), $sec * 1e3 if $sec < 1;
return sprintf "%$width.*fs", 3 - length(int($sec )), $sec if $sec < 100;
return sprintf "%$width.0fs", $sec;
@@ -7,11 +7,9 @@
## http://search.cpan.org/dist/Devel-NYTProf/
##
###########################################################
-## $Id$
-###########################################################
package Devel::NYTProf;
-our $VERSION = '4.23'; # also change in Devel::NYTProf::Core
+our $VERSION = '5.06'; # also change in Devel::NYTProf::Core
package # hide the package from the PAUSE indexer
DB;
@@ -182,7 +180,7 @@ statement executed in foo()>! Here's another example:
}
After the first time around the loop, any further time spent evaluating the
-condition (waiting for input in this example) would be be recorded as having
+condition (waiting for input in this example) would be recorded as having
been spent I<on the last statement executed in the loop>! (Until perl bug
#60954 is fixed this problem still applies to some loops. For more information
see L<http://rt.perl.org/rt3/Ticket/Display.html?id=60954>)
@@ -204,8 +202,8 @@ For each subroutine called, separate counts and durations are stored I<for each
location that called the subroutine>.
Subroutine entry is detected by intercepting the C<entersub> opcode. Subroutine
-exit is detected via perl's internal save stack. The result is both extremely
-fast and very robust.
+exit is detected via perl's internal save stack. As a result the subroutine
+profiler is both fast and robust.
=head3 Subroutine Recursion
@@ -370,13 +368,12 @@ If you find any other examples of the effect of optimizer on NYTProf output
Set to 0 to disable the collection of subroutine caller and timing details.
-=head2 blocks=0
+=head2 blocks=1
-Set to 0 to disable the determination of block and subroutine location per statement.
-This makes the profiler about 50% faster (as of July 2008) and produces smaller
-output files, but you lose some valuable information. The extra cost is likely
-to be reduced in later versions anyway, as little optimization has been done on
-that part of the code.
+Set to 1 to enable the determination of block and subroutine location per statement.
+This makes the profiler about 50% slower (as of July 2008) and produces larger
+output files, but you gain some valuable insight in where time is spent in the
+blocks within large subroutines and scripts.
=head2 stmts=0
@@ -387,6 +384,25 @@ This significantly reduces the overhead of the profiler and can also be useful
for profiling large applications that would normally generate a very large
profile data file.
+=head2 calls=N
+
+This option is I<new and experimental>.
+
+With calls=1 (the default) subroutine call I<return> events are emitted into
+the data stream as they happen. With calls=2 subroutine call I<entry> events
+are also emitted. With calls=0 no subroutine call events are produced.
+This option depends on the C<subs> option being enabled, which it is by default.
+
+The L<nytprofcalls> utility can be used to process this data. It too is I<new
+and experimental> and so likely to change.
+
+The subroutine profiler normally gathers data in memory and outputs a summary
+when the profile data is being finalized, usually when the program has finished.
+The summary contains aggregate information for all the calls from one location
+to another, but the details of individual calls have been lost.
+The calls option enables the recording of individual call events and thus
+more detailed analysis and reporting of that data.
+
=head2 leave=0
Set to 0 to disable the extra work done by the statement profiler
@@ -496,9 +512,10 @@ When perl exits normally it runs any code defined in C<END> blocks.
NYTProf defines an END block that finishes profiling and writes out the final
profile data.
-If the process ends due to a signal then END blocks are not executed.
-The C<sigexit> option tells NYTProf to catch some signals (e.g. INT, HUP, PIPE,
-SEGV, BUS) and ensure a usable by executing:
+If the process ends due to a signal then END blocks are not executed so the
+profile will be incomplete and unusable. The C<sigexit> option tells NYTProf
+to catch some signals (e.g. INT, HUP, PIPE, SEGV, BUS) and ensure a usable
+profile by executing:
DB::finish_profile();
exit 1;
@@ -518,6 +535,19 @@ When using the C<subs=0> option to disable the subroutine profiler the
C<posix_exit> option can be used to tell NYTProf to take other steps to arrange
for C<DB::finish_profile()> to be called before C<POSIX::_exit()>.
+=head2 libcexit=1
+
+Arranges for L</finish_profile> to be called via the C library C<atexit()> function.
+This may help some tricky cases where the process may exit without perl
+executing the C<END> block that NYTProf uses to call /finish_profile().
+
+=head2 endatexit=1
+
+Sets the PERL_EXIT_DESTRUCT_END flag in the PL_exit_flags of the perl interpreter.
+This makes perl run C<END> blocks in perl_destruct() instead of perl_run()
+which may help in cases, like Apache, where perl is embedded but perl_run()
+isn't called.
+
=head2 forkdepth=N
When a perl process that is being profiled executes a fork() the child process
@@ -567,7 +597,9 @@ to stop collecting profile data, and calling DB::enable_profile() to start
collecting profile data.
Using the C<start=no> option lets you leave the profiler disabled initially
-until you call DB::enable_profile() at the right moment.
+until you call DB::enable_profile() at the right moment. You still need to
+load Devel::NYTProf as early as possible, even if you don't call
+DB::enable_profile() until much later. See also L</use_db_sub=1>.
The profile output file can't be used until it's been properly completed and
closed. Calling DB::disable_profile() doesn't do that. To make a profile file
@@ -767,20 +799,20 @@ You can reduce the cost of profiling by adjusting some options. The trade-off
is reduced detail and/or accuracy in reports.
If you don't need statement-level profiling then you can disable it via L</stmts=0>.
-If you do want it but don't mind loosing block-level timings then set L</blocks=0>.
To further boost statement-level profiling performance try L</leave=0> but note that
I<will> apportion timings for some kinds of statements less accurate).
+If you don't need call stacks or flamegraph then disable it via L</calls=0>.
If you don't need subroutine profiling then you can disable it via L</subs=0>.
If you do need it but don't need timings for perl opcodes then set L</slowops=0>.
-Generally speaking, setting blocks=0 and slowops=0 will give you a useful boost
+Generally speaking, setting calls=0 and slowops=0 will give you a useful boost
with the least loss of detail.
Another approach is to only enable NYTProf in the sections of code that
interest you. See L</RUN-TIME CONTROL OF PROFILING> for more details.
-To speed up L<nytprofhtml> try using the --minimal (-m) option.
+To speed up L<nytprofhtml> try using the --minimal (-m) or --no-flame options.
=head1 REPORTS
@@ -800,15 +832,15 @@ Creates attractive, richly annotated, and fully cross-linked html
reports (including statistics, source code and color highlighting).
This is the main report generation tool for NYTProf.
-=head2 nytprofcsv
-
-Creates comma delimited profile reports. Old and limited.
-
=head2 nytprofcg
Translates a profile into a format that can be loaded into KCachegrind
L<http://kcachegrind.sourceforge.net>
+=head2 nytprofcalls
+
+Reads a profile and processes the calls events it contains.
+
=head2 nytprofmerge
Reads multiple profile data files and writes out a new file containing the merged profile data.
@@ -980,6 +1012,10 @@ Why 'realtime' can appear to go backwards:
http://preview.tinyurl.com/5wawnn
+The PostgreSQL pg_test_timing utility documentation has a good summary of timing issues:
+
+ http://www.postgresql.org/docs/9.2/static/pgtesttiming.html
+
=for comment
http://preview.tinyurl.com/5wawnn redirects to:
http://groups.google.com/group/comp.os.linux.development.apps/tree/browse_frm/thread/dc29071f2417f75f/ac44671fdb35f6db?rnum=1&_done=%2Fgroup%2Fcomp.os.linux.development.apps%2Fbrowse_frm%2Fthread%2Fdc29071f2417f75f%2Fc46264dba0863463%3Flnk%3Dst%26rnum%3D1%26
@@ -1091,6 +1127,10 @@ it's very likely to be deprecated in a future release).
L<Devel::NYTProf::ReadStream> is the module that lets you read a profile data
file as a stream of chunks of data.
+Other tools:
+
+DTrace L<https://speakerdeck.com/mrallen1/perl-dtrace-and-you>
+
=head1 TROUBLESHOOTING
=head2 "Profile data incomplete, ..." or "File format error: ..."
@@ -1185,7 +1225,7 @@ For more details see L</HISTORY> below.
=head1 COPYRIGHT AND LICENSE
Copyright (C) 2008 by Adam Kaplan and The New York Times Company.
- Copyright (C) 2008-2010 by Tim Bunce, Ireland.
+ Copyright (C) 2008-2013 by Tim Bunce, Ireland.
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself, either Perl version 5.8.8 or,
@@ -1,11 +1,11 @@
use Test::More;
use strict;
-use lib qw(t/lib);
use Config;
-use NYTProfTest;
+use Data::Dumper;
-plan tests => 20;
+use lib qw(t/lib);
+use NYTProfTest;
use Devel::NYTProf::ReadStream qw(for_chunks);
@@ -15,7 +15,7 @@ my $pre589 = ($] < 5.008009 or $] eq "5.010000");
# generate an nytprof out file
my $out = 'nytprof_readstream.out';
-$ENV{NYTPROF} = "file=$out";
+$ENV{NYTPROF} = "calls=2:blocks=1:file=$out";
unlink $out;
run_perl_command(qq{-d:NYTProf -e "sub A { };" -e "1;" -e "A() $Devel::NYTProf::StrEvalTestPad"});
@@ -35,22 +35,34 @@ for_chunks {
}
} filename => $out;
+my %option = map { @$_ } @{$prof{OPTION}};
+cmp_ok scalar keys %option, '>=', 17, 'enough options';
+#diag Dumper(\%option);
+
+my %attribute = map { @$_ } @{$prof{ATTRIBUTE}};
+cmp_ok scalar keys %attribute, '>=', 9, 'enough attribute';
+#diag Dumper(\%attribute);
+
ok scalar @seqn, 'should have read chunks';
is_deeply(\@seqn, [0..@seqn-1], "chunk seq");
#use Data::Dumper; warn Dumper \%prof;
-is_deeply $prof{VERSION}, [ [ 4, 0 ] ];
+is_deeply $prof{VERSION}, [ [ 5, 0 ] ];
# check for expected tags
# but not START_DEFLATE as that'll be missing if there's no zlib
# and not SRC_LINE as old perl's
-for my $tag (qw(
- COMMENT ATTRIBUTE DISCOUNT TIME_BLOCK
- SUB_INFO SUB_CALLERS
- PID_START PID_END NEW_FID
-)) {
- is ref $prof{$tag}[0], 'ARRAY', $tag;
+my @expected_tags = qw(
+ COMMENT ATTRIBUTE OPTION DISCOUNT
+ SUB_INFO SUB_CALLERS
+ PID_START PID_END NEW_FID
+ SUB_ENTRY SUB_RETURN
+);
+push @expected_tags, 'TIME_BLOCK' if $option{calls};
+for my $tag (@expected_tags) {
+ is ref $prof{$tag}[0], 'ARRAY', "raw $tag array seen"
+ or diag Dumper $prof{$tag};
}
SKIP: {
@@ -77,3 +89,10 @@ $prof{SUB_CALLERS}[0][$_] = 0 for (3,4);
is_deeply $prof{SUB_CALLERS}, [
[ 1, 3, 1, 0, 0, '0', 0, 'main::A', 'main::RUNTIME' ]
];
+
+is_deeply $prof{SUB_ENTRY}, [ [ 1, 3 ] ], 'SUB_ENTRY args';
+
+$prof{SUB_RETURN}[0][$_] = 0 for (1,2);
+is_deeply $prof{SUB_RETURN}, [ [ 1, 0, 0, 'main::A' ] ], 'SUB_RETURN args';
+
+done_testing();
@@ -6,7 +6,7 @@ use Devel::NYTProf::Util qw(
trace_level
);
-my $us = "µs";
+my $us = "µs";
is(fmt_time(0), "0s");
@@ -2,6 +2,7 @@
use strict;
use Test::More;
+use Test::Differences;
use lib qw(t/lib);
use NYTProfTest;
@@ -47,7 +48,7 @@ run_test_group( {
my $subs2 = $profile->subs_defined_in_file($fid);
- is_deeply [ keys %$subs2 ], [ keys %$subs1 ],
+ eq_or_diff [ sort keys %$subs2 ], [ sort keys %$subs1 ],
'keys from subname_subinfo_map and subs_defined_in_file should match';
my @begins = grep { $_->subname =~ /\bBEGIN\b/ } values %$subs2;
@@ -9,6 +9,7 @@ use ExtUtils::testlib;
use Getopt::Long;
use Test::More;
use Data::Dumper;
+use File::Spec;
use File::Temp qw(tempfile);
use List::Util qw(shuffle);
@@ -34,7 +35,7 @@ my %opts = (
html => $ENV{NYTPROF_TEST_HTML},
mergerdt => $ENV{NYTPROF_TEST_MERGERDT}, # overkill, but handy
);
-GetOptions(\%opts, qw/p=s I=s v|verbose d|debug html open profperlopts=s leave=i use_db_sub=i savesrc=i compress=i one abort/)
+GetOptions(\%opts, qw/p=s I=s v|verbose d|debug html open profperlopts=s blocks=i leave=i use_db_sub=i savesrc=i compress=i one abort/)
or exit 1;
$opts{v} ||= $opts{d};
@@ -60,10 +61,11 @@ for my $opt (qw(trace)) {
}
-my $tests_per_extn = {
- p => 1,
- rdt => ($opts{mergerdt}) ? 2 : 1,
- x => 3
+my $text_extn_info = {
+ p => { order => 10, tests => 1, },
+ rdt => { order => 20, tests => ($opts{mergerdt}) ? 2 : 1, },
+ x => { order => 30, tests => 3, },
+ calls => { order => 40, tests => 1, },
};
chdir('t') if -d 't';
@@ -77,9 +79,10 @@ my $bindir = (grep {-d} qw(./blib/script ../blib/script))[0] || do {
warn "Couldn't find blib/script directory, so using $bin";
$bin;
};
-my $nytprofcsv = "$bindir/nytprofcsv";
-my $nytprofhtml = "$bindir/nytprofhtml";
-my $nytprofmerge= "$bindir/nytprofmerge";
+my $nytprofcsv = File::Spec->catfile($bindir, "nytprofcsv");
+my $nytprofcalls = File::Spec->catfile($bindir, "nytprofcalls");
+my $nytprofhtml = File::Spec->catfile($bindir, "nytprofhtml");
+my $nytprofmerge = File::Spec->catfile($bindir, "nytprofmerge");
my $path_sep = $Config{path_sep} || ':';
my $perl5lib = $opts{I} || join($path_sep, @INC);
@@ -94,41 +97,51 @@ if ($opts{one}) { # for one quick test
$opts{use_db_sub} = 0;
$opts{savesrc} = 1;
$opts{compress} = 1;
+ $opts{calls} = 2;
+ $opts{blocks} = 1;
}
# force savesrc off for perl 5.11.2 due to perl bug RT#70804
$opts{savesrc} = 0 if $] eq "5.011002";
+my @test_opt_blocks = (defined $opts{blocks}) ? ($opts{blocks}) : (1);
my @test_opt_leave = (defined $opts{leave}) ? ($opts{leave}) : (0, 1);
my @test_opt_use_db_sub = (defined $opts{use_db_sub}) ? ($opts{use_db_sub}) : (0, 1);
my @test_opt_savesrc = (defined $opts{savesrc}) ? ($opts{savesrc}) : (0, 1);
my @test_opt_compress = (defined $opts{compress}) ? ($opts{compress}) : (0, 1);
+my @test_opt_calls = (defined $opts{calls}) ? ($opts{calls}) : (0, 1, 2);
sub mk_opt_combinations {
my ($overrides) = @_;
my @opt_combinations;
my %seen;
+
+ for my $blocks (@test_opt_blocks) {
for my $leave (@test_opt_leave) {
- for my $use_db_sub (@test_opt_use_db_sub) {
- for my $savesrc (@test_opt_savesrc) {
- for my $compress (@test_opt_compress) {
- my $o = {
- start => 'init',
- slowops => 2,
- leave => $leave,
- use_db_sub => $use_db_sub,
- savesrc => $savesrc,
- compress => $compress,
- ($overrides) ? %$overrides : (),
- };
- my $key = join "\t", map { "$_=>$o->{$_}" } sort keys %$o;
- next if $seen{$key}++;
- push @opt_combinations, $o;
- }
- }
- }
- }
+ for my $use_db_sub (@test_opt_use_db_sub) {
+ for my $savesrc (@test_opt_savesrc) {
+ for my $compress (@test_opt_compress) {
+
+ my $o = {
+ start => 'init',
+ slowops => 2,
+ blocks => $blocks,
+ leave => $leave,
+ use_db_sub => $use_db_sub,
+ savesrc => $savesrc,
+ compress => $compress,
+ # we don't need to test the 'calls' opt with all other combinations
+ # so we fudge it here to be on most, but not all, of the time
+ calls => (!!$savesrc + !!$compress), # 0|1|2
+ ($overrides) ? %$overrides : (),
+ };
+ my $key = join "\t", map { "$_=>$o->{$_}" } sort keys %$o;
+ next if $seen{$key}++;
+ push @opt_combinations, $o;
+
+ } } } } }
+
@opt_combinations = shuffle @opt_combinations;
return \@opt_combinations;
}
@@ -165,7 +178,7 @@ sub do_foreach_opt_combination {
# did any tests fail?
my $failed = (count_of_failed_tests() - $prev_failures) ? 1 : 0;
# record what env settings may have influenced the failure
- ++$env_influence{$_}{$env->{$_}}{$failed ? 'fail' : 'pass'}
+ ++$env_influence{$_}{$env->{$_}}{$failed ? 'FAIL' : 'pass'}
for keys %$env;
$env_failed{ $ENV{NYTPROF} } = $failed;
}
@@ -181,15 +194,21 @@ sub report_env_influence {
my @env_influence;
for my $envvar (sort keys %env_influence) {
my $variants = $env_influence{$envvar};
+
local $Data::Dumper::Indent = 0;
local $Data::Dumper::Sortkeys = 1;
local $Data::Dumper::Terse = 1;
local $Data::Dumper::Quotekeys= 0;
local $Data::Dumper::Pair = ' ';
$variants->{$_} = Dumper($variants->{$_}) for keys %$variants;
+
+ # was there at least one failure?
+ next unless grep { /FAIL/ } values %$variants;
+
my $v = (values %$variants)[0]; # use one as a reference
# all the same?
next if keys %$variants == grep { $_ eq $v } values %$variants;
+
push @env_influence, sprintf "%15s: %s\n", $envvar,
join ', ', map { "$_ => $variants->{$_}" } sort keys %$variants;
}
@@ -229,14 +248,17 @@ sub run_test_group {
croak "Can't determine test group";
}
- my @tests = grep { -f $_ } map { "$group.$_" } sort keys %$tests_per_extn;
- unlink <$group.*_new{,p}>; # delete _new and _newp files from previous run
+ my @tests = grep { -f $_ }
+ map { "$group.$_" }
+ sort { $text_extn_info->{$a}{order} <=> $text_extn_info->{$b}{order} }
+ keys %$text_extn_info;
+ unlink <$group.*_new*>; # delete _new* files from previous run
if ($opts{v}) {
print "tests: @tests\n";
print "perl: $perl\n";
print "perl5lib: $perl5lib\n";
- print "nytprofcvs: $nytprofcsv\n";
+ print "nytprofbin: $bindir\n";
}
plan skip_all => "No '$group.*' test files and no extra_test_code"
@@ -317,7 +339,7 @@ sub run_test {
if ($opts{mergerdt}) { # run the file through nytprofmerge
my $merged = "$profile_datafile.merged";
- my $merge_cmd = "$nytprofmerge -v --out=$merged $test_datafile";
+ my $merge_cmd = "$perl $nytprofmerge -v --out=$merged $test_datafile";
warn "$merge_cmd\n";
system($merge_cmd) == 0
or die "Error running $merge_cmd\n";
@@ -325,6 +347,14 @@ sub run_test {
unlink $merged;
}
}
+ elsif ($type eq 'calls') {
+ if ($env->{calls}) {
+ verify_calls_report($test, $tag, $test_datafile, $outdir);
+ }
+ else {
+ pass("no calls");
+ }
+ }
elsif ($type eq 'x') {
mkdir $outdir or die "mkdir($outdir): $!" unless -d $outdir;
unlink <$outdir/*>;
@@ -376,7 +406,7 @@ sub run_perl_command {
}
-sub profile {
+sub profile { # TODO refactor to use run_perl_command()?
my ($test, $profile_datafile) = @_;
my @perl = perl_command_words(skip_sitecustomize => 1);
@@ -398,16 +428,23 @@ sub verify_data {
SKIP: {
skip 'Expected profile data does not have VMS paths', 1
if $^O eq 'VMS' and $test =~ m/test60|test14/i;
- $profile->normalize_variables;
+ $profile->normalize_variables(1); # and options
dump_profile_to_file($profile, $test.'_new', $test.'_newp');
- my @got = slurp_file($test.'_new'); chomp @got;
- my @expected = slurp_file($test); chomp @expected;
- is_deeply(\@got, \@expected, "$test match generated profile data for $tag")
- ? unlink($test.'_new')
- : diff_files($test, $test.'_new', $test.'_newp');
+ is_file_content_same($test.'_new', $test, "$test match generated profile data for $tag");
}
}
+sub is_file_content_same {
+ my ($got_file, $exp_file, $testname) = @_;
+
+ my @got = slurp_file($got_file); chomp @got;
+ my @exp = slurp_file($exp_file); chomp @exp;
+
+ is_deeply(\@got, \@exp, $testname)
+ ? unlink($got_file)
+ : diff_files($exp_file, $got_file, $got_file."_patch");
+}
+
sub dump_data_to_file {
my ($profile, $file) = @_;
@@ -446,6 +483,15 @@ sub diff_files {
}
+sub verify_calls_report {
+ my ($test, $tag, $profile_datafile, $outdir) = @_;
+ my $got_file = "${test}_new";
+ note "generating $got_file";
+ run_command("$perl $nytprofcalls $profile_datafile -stable --calls > $got_file");
+ is_file_content_same($got_file, $test, "$test match generated calls data for $tag");
+}
+
+
sub verify_csv_report {
my ($test, $tag, $profile_datafile, $outdir) = @_;
@@ -494,8 +540,7 @@ sub verify_csv_report {
# slow systems, e.g. cpan-testers running in cpu-starved virtual machines.
# e.g., http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4227689.html
my $max_time_overrun_percentage = ($automated_testing) ? 400 : 200;
- # e.g., http://www.nntp.perl.org/group/perl.cpan.testers/2009/06/msg4230206.html
- my $max_time_underrun_percentage = 90;
+ my $max_time_underrun_percentage = 80;
my @accuracy_errors;
$index = 0;
@@ -505,7 +550,8 @@ sub verify_csv_report {
next if m/^# Version/; # Ignore version numbers
- s/^([0-9.]+),([0-9.]+),([0-9.]+),(.*)$/0,$2,0,$4/o;
+ # we allow negative numbers here re RT#85556
+ s/^(-?[0-9.]+),([0-9.]+),([0-9.]+),(.*)$/0,$2,0,$4/o;
my $t0 = $1;
my $c0 = $2;
my $tc0 = $3;
@@ -563,7 +609,7 @@ sub number_of_tests {
my $total_tests = 0;
for (@_) {
next unless m/\.(\w+)$/;
- my $tests = $tests_per_extn->{$1};
+ my $tests = $text_extn_info->{$1}{tests};
warn "Unknown test type '$1' for test file '$_'\n" if not defined $tests;
$total_tests += $tests if $tests;
}
@@ -0,0 +1,14 @@
+main::bar 1
+main::bar;main::CORE:print 1
+main::foo 1
+main::foo;main::CORE:print 1
+main::foo;main::bar 1
+main::foo;main::bar;main::CORE:print 1
+main::baz 1
+main::baz;main::CORE:print 1
+main::baz;main::bar 1
+main::baz;main::bar;main::CORE:print 1
+main::baz;main::foo 1
+main::baz;main::foo;main::CORE:print 1
+main::baz;main::foo;main::bar 1
+main::baz;main::foo;main::bar;main::CORE:print 1
@@ -0,0 +1,14 @@
+main::bar 2
+main::bar;main::CORE:print 2
+main::foo 1
+main::foo;main::CORE:print 1
+main::foo;main::bar 1
+main::foo;main::bar;main::CORE:print 1
+main::baz 1
+main::baz;main::CORE:print 1
+main::baz;main::bar 3
+main::baz;main::bar;main::CORE:print 3
+main::baz;main::foo 1
+main::baz;main::foo;main::CORE:print 1
+main::baz;main::foo;main::bar 1
+main::baz;main::foo;main::bar;main::CORE:print 1
@@ -0,0 +1,8 @@
+main::bar 1
+main::bar;main::CORE:print 1
+main::baz 1
+main::baz;main::CORE:print 1
+main::baz;main::bar 1
+main::baz;main::bar;main::CORE:print 1
+main::baz;main::foo 1
+main::baz;main::foo;main::CORE:print 1
@@ -0,0 +1,12 @@
+main::foo1 1
+main::foo1;main::CORE:print 1
+main::foo1;main::bar 1
+main::foo1;main::bar;main::CORE:print 1
+main::foo1;main::bar;main::yeppers 1
+main::foo1;main::bar;main::yeppers;main::CORE:print 1
+main::foo2 1
+main::foo2;main::CORE:print 1
+main::foo2;main::bar 1
+main::foo2;main::bar;main::CORE:print 1
+main::foo2;main::bar;main::yeppers 1
+main::foo2;main::bar;main::yeppers;main::CORE:print 1
@@ -0,0 +1,9 @@
+main::foo 1
+main::foo;main::CORE:print 1
+main::foo;main::noop 110
+main::bar 1
+main::bar;main::CORE:print 1
+main::bar;main::noop 100
+main::baz 1
+main::baz;main::CORE:print 1
+main::baz;main::noop 200
@@ -0,0 +1 @@
+main::CORE:print 1
diff --git a/var/tmp/source/TIMB/Devel-NYTProf-5.06/Devel-NYTProf-5.06/t/test08.calls b/var/tmp/source/TIMB/Devel-NYTProf-5.06/Devel-NYTProf-5.06/t/test08.calls
new file mode 100644
index 00000000..e69de29b
@@ -0,0 +1,3 @@
+main::bar 1
+main::foo 2
+main::foo;main::bar 2
@@ -0,0 +1,2 @@
+main::__ANON__[(eval 0)[test10.p:1]:1] 1
+main::__ANON__[(eval 0)[test10.p:1]:1];main::CORE:sleep 1
@@ -0,0 +1 @@
+main::__ANON__[(eval 0)[test11.p:3]:1] 2
diff --git a/var/tmp/source/TIMB/Devel-NYTProf-5.06/Devel-NYTProf-5.06/t/test12.calls b/var/tmp/source/TIMB/Devel-NYTProf-5.06/Devel-NYTProf-5.06/t/test12.calls
new file mode 100644
index 00000000..e69de29b
@@ -0,0 +1,9 @@
+main::foo 1
+main::foo;main::CORE:print 1
+main::bar 1
+main::bar;main::CORE:print 1
+main::baz 1
+main::baz;main::CORE:print 1
+main::baz;main::foo 2
+main::baz;main::foo;main::CORE:print 2
+main::baz;main::x 1
@@ -0,0 +1,6 @@
+main::foo 2
+main::foo;main::CORE:match 3
+main::foo;main::CORE:say 2
+main::bar 2
+main::bar;main::CORE:match 3
+main::bar;main::CORE:print 2
@@ -0,0 +1,6 @@
+main::origin 1
+main::origin;main::other 1
+main::destination 1
+main::destination;main::other 1
+main::foo 1
+main::foo;main::bar 1
@@ -0,0 +1,3 @@
+Test18::longmess 1
+Test18::longmess_jmp 1
+Test18::longmess_real 1
@@ -0,0 +1,2 @@
+main::foo 4
+main::foo;main::CORE:print 4
@@ -0,0 +1,2 @@
+main::CORE:sselect 3
+main::foo 3
@@ -0,0 +1,6 @@
+main::__ANON__[(eval 0)[test22-strevala.p:6]:2] 1
+main::__ANON__[(eval 0)[test22-strevala.p:6]:2];main::CORE:print 1
+main::__ANON__[(eval 0)[test22-strevala.p:9]:2] 2
+main::__ANON__[(eval 0)[test22-strevala.p:9]:2];main::CORE:print 2
+main::__ANON__[(eval 0)[(eval 0)[test22-strevala.p:12]:2]:2] 2
+main::__ANON__[(eval 0)[(eval 0)[test22-strevala.p:12]:2]:2];main::CORE:print 2
@@ -52,6 +52,8 @@ run_test_group( {
},
} );
+exit 0;
+
__END__
my $code = 'sub { print "sub called\n" }';
eval($code)->();
diff --git a/var/tmp/source/TIMB/Devel-NYTProf-5.06/Devel-NYTProf-5.06/t/test23-strevall.calls b/var/tmp/source/TIMB/Devel-NYTProf-5.06/Devel-NYTProf-5.06/t/test23-strevall.calls
new file mode 100644
index 00000000..e69de29b
@@ -0,0 +1 @@
+main::__ANON__[(eval 0)[test24-strevalc.p:8]:1] 2
@@ -0,0 +1,11 @@
+main::other 1
+main::other;main::CORE:print 1
+main::prefork 1
+main::prefork;main::CORE:print 1
+main::prefork;main::other 1
+main::prefork;main::other;main::CORE:print 1
+main::postfork 1
+main::postfork;main::CORE:print 1
+main::postfork;main::other 1
+main::postfork;main::other;main::CORE:print 1
+main::CORE:wait 1
@@ -0,0 +1 @@
+test40pmc::foo 1
@@ -0,0 +1 @@
+DB::disable_profile 2
@@ -0,0 +1,3 @@
+main::CORE:unlink 1
+main::sub1 1
+DB::disable_profile 1
@@ -47,3 +47,5 @@ DB::finish_profile();
# This can be removed once we have a better test harness
-f $_ or die "$_ should exist" for ($file_b, $file_c);
+
+# TODO should test for enable/disable within subs
@@ -50,3 +50,5 @@
0,0,0,
0,0,0,# This can be removed once we have a better test harness
0,0,0,-f $_ or die "$_ should exist" for ($file_b, $file_c);
+0,0,0,
+0,0,0,# TODO should test for enable/disable within subs
@@ -0,0 +1,5 @@
+Devel::NYTProf::Test::example_xsub 7
+Devel::NYTProf::Test::example_xsub;main::will_die 1
+main::launch 1
+main::CORE:wait 1
+main::CORE:open 1
@@ -0,0 +1,3 @@
+main::__ANON__[(eval 0)[test61-submerge.p:8]:1] 3
+main::__ANON__[(eval 0)[test61-submerge.p:8]:1];main::foo 3
+main::__ANON__[(eval 0)[test61-submerge.p:8]:1];main::foo;main::CORE:print 3
@@ -0,0 +1,11 @@
+MyTie::TIESCALAR 1
+main::sub4 2
+MyTie::STORE 1
+MyTie::FETCH 1
+Devel::NYTProf::Test::example_xsub 2
+main::sub1 1
+main::CORE:sort 2
+main::CORE:sort;Devel::NYTProf::Test::example_xsub 3
+main::CORE:sort;main::sub2 6
+main::CORE:subst 1
+main::CORE:substcont 3
@@ -0,0 +1,6 @@
+main::D 1
+main::D;main::C 2
+main::D;main::C;main::B 2
+main::D;main::C;main::B;main::CORE:sselect 2
+main::D;main::C;main::B;main::A 2
+main::D;main::C;main::B;main::A;main::CORE:sselect 2
@@ -5,7 +5,7 @@
# code using a command like
# make && NYTPROF_TEST=trace=3 perl -Mblib test.pl -leave=1 -use_db_sub=0 t/test70-subexcl.*
-my $T = 0.2;
+my $T = $ENV{NYTPROF_TEST_PAUSE_TIME} || 0.2;
sub A { # inclusive ~= $T, exclusive ~= $T
select undef, undef, undef, $T;
@@ -0,0 +1,6 @@
+main::recurs 1
+main::recurs;main::CORE:sselect 1
+main::recurs;main::recurs 1
+main::recurs;main::recurs;main::CORE:sselect 1
+main::recurs;main::recurs;main::recurs 1
+main::recurs;main::recurs;main::recurs;main::CORE:sselect 1
@@ -0,0 +1,45 @@
+# Tests dieing on Can't use string ... as a subroutine ref while "strict refs" in use
+# that used to core dump (RT#86638)
+# https://rt.cpan.org/Ticket/Display.html?id=86638
+
+use strict;
+use Test::More;
+
+use lib qw(t/lib);
+use NYTProfTest;
+use Data::Dumper;
+
+use Devel::NYTProf::Run qw(profile_this);
+
+my $src_code = join("", <DATA>);
+
+run_test_group( {
+ extra_options => {
+ start => 'begin',
+ compress => 1,
+ calls => 0,
+ savesrc => 0,
+ stmts => 0,
+ slowops => 0,
+ },
+ extra_test_count => 2,
+ extra_test_code => sub {
+ my ($profile, $env) = @_;
+
+ $profile = profile_this(
+ src_code => $src_code,
+ out_file => $env->{file},
+ skip_sitecustomize => 1,
+ );
+ isa_ok $profile, 'Devel::NYTProf::Data';
+ # check if data was truncated
+ ok $profile->{attribute}{complete};
+ },
+});
+
+__DATA__
+#!perl
+use strict;
+# Can't use string ("") as a subroutine ref while "strict refs" in use at - line 4.
+eval { $x::z->() };
+die $@ if $@ !~ /^Can't use .* as a subroutine ref/;