You are viewing a plain text version of this content. The canonical link for it is here.
Posted to dev@brpc.apache.org by ja...@apache.org on 2019/08/05 04:57:05 UTC
[incubator-brpc] branch master updated: Add flamegraph view for
profiling builtin service
This is an automated email from the ASF dual-hosted git repository.
jamesge pushed a commit to branch master
in repository https://gitbox.apache.org/repos/asf/incubator-brpc.git
The following commit(s) were added to refs/heads/master by this push:
new 613bcc7 Add flamegraph view for profiling builtin service
new a6689a2 Merge pull request #864 from skilxnTL/master
613bcc7 is described below
commit 613bcc7bed6ef028b8a86741ece263049f8e3f8c
Author: skilxnTL <ty...@gmail.com>
AuthorDate: Tue Jul 30 17:15:18 2019 +0800
Add flamegraph view for profiling builtin service
---
src/brpc/builtin/flamegraph_perl.cpp | 1192 ++++++++++++++
src/brpc/builtin/flamegraph_perl.h | 25 +
src/brpc/builtin/hotspots_service.cpp | 188 ++-
src/brpc/builtin/pprof_perl.cpp | 2740 ++++++++++++++++++++++++++++-----
4 files changed, 3709 insertions(+), 436 deletions(-)
diff --git a/src/brpc/builtin/flamegraph_perl.cpp b/src/brpc/builtin/flamegraph_perl.cpp
new file mode 100644
index 0000000..4f00315
--- /dev/null
+++ b/src/brpc/builtin/flamegraph_perl.cpp
@@ -0,0 +1,1192 @@
+// Copyright 2016 Netflix, Inc.
+// 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 docs/cddl1.txt 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 docs/cddl1.txt.
+// 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
+//
+// 11-Oct-2014 Adrien Mahieux Added zoom.
+// 21-Nov-2013 Shawn Sterling Added consistent palette file option
+// 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.
+
+#include "brpc/builtin/flamegraph_perl.h"
+
+namespace brpc {
+
+const char* flamegraph_perl() {
+ return "#!/usr/bin/perl -w\n"
+ "#\n"
+ "# flamegraph.pl flame stack grapher.\n"
+ "#\n"
+ "# This takes stack samples and renders a call graph, allowing hot functions\n"
+ "# and codepaths to be quickly identified. Stack samples can be generated using\n"
+ "# tools such as DTrace, perf, SystemTap, and Instruments.\n"
+ "#\n"
+ "# USAGE: ./flamegraph.pl [options] input.txt > graph.svg\n"
+ "#\n"
+ "# grep funcA input.txt | ./flamegraph.pl [options] > graph.svg\n"
+ "#\n"
+ "# Then open the resulting .svg in a web browser, for interactivity: mouse-over\n"
+ "# frames for info, click to zoom, and ctrl-F to search.\n"
+ "#\n"
+ "# Options are listed in the usage message (--help).\n"
+ "#\n"
+ "# The input is stack frames and sample counts formatted as single lines. Each\n"
+ "# frame in the stack is semicolon separated, with a space and count at the end\n"
+ "# of the line. These can be generated for Linux perf script output using\n"
+ "# stackcollapse-perf.pl, for DTrace using stackcollapse.pl, and for other tools\n"
+ "# using the other stackcollapse programs. Example input:\n"
+ "#\n"
+ "# swapper;start_kernel;rest_init;cpu_idle;default_idle;native_safe_halt 1\n"
+ "#\n"
+ "# An optional extra column of counts can be provided to generate a differential\n"
+ "# flame graph of the counts, colored red for more, and blue for less. This\n"
+ "# can be useful when using flame graphs for non-regression testing.\n"
+ "# See the header comment in the difffolded.pl program for instructions.\n"
+ "#\n"
+ "# The input functions can optionally have annotations at the end of each\n"
+ "# function name, following a precedent by some tools (Linux perf's _[k]):\n"
+ "# _[k] for kernel\n"
+ "# _[i] for inlined\n"
+ "# _[j] for jit\n"
+ "# _[w] for waker\n"
+ "# Some of the stackcollapse programs support adding these annotations, eg,\n"
+ "# stackcollapse-perf.pl --kernel --jit. They are used merely for colors by\n"
+ "# some palettes, eg, flamegraph.pl --color=java.\n"
+ "#\n"
+ "# The output flame graph shows relative presence of functions in stack samples.\n"
+ "# The ordering on the x-axis has no meaning; since the data is samples, time\n"
+ "# order of events is not known. The order used sorts function names\n"
+ "# alphabetically.\n"
+ "#\n"
+ "# While intended to process stack samples, this can also process stack traces.\n"
+ "# For example, tracing stacks for memory allocation, or resource usage. You\n"
+ "# can use --title to set the title to reflect the content, and --countname\n"
+ "# to change \"samples\" to \"bytes\" etc.\n"
+ "#\n"
+ "# There are a few different palettes, selectable using --color. By default,\n"
+ "# the colors are selected at random (except for differentials). Functions\n"
+ "# called \"-\" will be printed gray, which can be used for stack separators (eg,\n"
+ "# between user and kernel stacks).\n"
+ "#\n"
+ "# HISTORY\n"
+ "#\n"
+ "# This was inspired by Neelakanth Nadgir's excellent function_call_graph.rb\n"
+ "# program, which visualized function entry and return trace events. As Neel\n"
+ "# wrote: \"The output displayed is inspired by Roch's CallStackAnalyzer which\n"
+ "# was in turn inspired by the work on vftrace by Jan Boerhout\". See:\n"
+ "# https://blogs.oracle.com/realneel/entry/visualizing_callstacks_via_dtrace_and\n"
+ "#\n"
+ "# Copyright 2016 Netflix, Inc.\n"
+ "# Copyright 2011 Joyent, Inc. All rights reserved.\n"
+ "# Copyright 2011 Brendan Gregg. All rights reserved.\n"
+ "#\n"
+ "# CDDL HEADER START\n"
+ "#\n"
+ "# The contents of this file are subject to the terms of the\n"
+ "# Common Development and Distribution License (the \"License\").\n"
+ "# You may not use this file except in compliance with the License.\n"
+ "#\n"
+ "# You can obtain a copy of the license at docs/cddl1.txt or\n"
+ "# http://opensource.org/licenses/CDDL-1.0.\n"
+ "# See the License for the specific language governing permissions\n"
+ "# and limitations under the License.\n"
+ "#\n"
+ "# When distributing Covered Code, include this CDDL HEADER in each\n"
+ "# file and include the License file at docs/cddl1.txt.\n"
+ "# If applicable, add the following below this CDDL HEADER, with the\n"
+ "# fields enclosed by brackets \"[]\" replaced with your own identifying\n"
+ "# information: Portions Copyright [yyyy] [name of copyright owner]\n"
+ "#\n"
+ "# CDDL HEADER END\n"
+ "#\n"
+ "# 11-Oct-2014 Adrien Mahieux Added zoom.\n"
+ "# 21-Nov-2013 Shawn Sterling Added consistent palette file option\n"
+ "# 17-Mar-2013 Tim Bunce Added options and more tunables.\n"
+ "# 15-Dec-2011 Dave Pacheco Support for frames with whitespace.\n"
+ "# 10-Sep-2011 Brendan Gregg Created this.\n"
+ "\n"
+ "use strict;\n"
+ "\n"
+ "use Getopt::Long;\n"
+ "\n"
+ "use open qw(:std :utf8);\n"
+ "\n"
+ "# tunables\n"
+ "my $encoding;\n"
+ "my $fonttype = \"Verdana\";\n"
+ "my $imagewidth = 1200; # max width, pixels\n"
+ "my $frameheight = 16; # max height is dynamic\n"
+ "my $fontsize = 12; # base text size\n"
+ "my $fontwidth = 0.59; # avg width relative to fontsize\n"
+ "my $minwidth = 0.1; # min function width, pixels\n"
+ "my $nametype = \"Function:\"; # what are the names in the data?\n"
+ "my $countname = \"samples\"; # what are the counts in the data?\n"
+ "my $colors = \"hot\"; # color theme\n"
+ "my $bgcolor1 = \"#eeeeee\"; # background color gradient start\n"
+ "my $bgcolor2 = \"#eeeeb0\"; # background color gradient stop\n"
+ "my $nameattrfile; # file holding function attributes\n"
+ "my $timemax; # (override the) sum of the counts\n"
+ "my $factor = 1; # factor to scale counts by\n"
+ "my $hash = 0; # color by function name\n"
+ "my $palette = 0; # if we use consistent palettes (default off)\n"
+ "my %palette_map; # palette map hash\n"
+ "my $pal_file = \"palette.map\"; # palette map file name\n"
+ "my $stackreverse = 0; # reverse stack order, switching merge end\n"
+ "my $inverted = 0; # icicle graph\n"
+ "my $negate = 0; # switch differential hues\n"
+ "my $titletext = \"\"; # centered heading\n"
+ "my $titledefault = \"Flame Graph\"; # overwritten by --title\n"
+ "my $titleinverted = \"Icicle Graph\"; # \" \"\n"
+ "my $searchcolor = \"rgb(230,0,230)\"; # color for search highlighting\n"
+ "my $notestext = \"\"; # embedded notes in SVG\n"
+ "my $subtitletext = \"\"; # second level title (optional)\n"
+ "my $help = 0;\n"
+ "\n"
+ "sub usage {\n"
+ " die <<USAGE_END;\n"
+ "USAGE: $0 [options] infile > outfile.svg\\n\n"
+ " --title TEXT # change title text\n"
+ " --subtitle TEXT # second level title (optional)\n"
+ " --width NUM # width of image (default 1200)\n"
+ " --height NUM # height of each frame (default 16)\n"
+ " --minwidth NUM # omit smaller functions (default 0.1 pixels)\n"
+ " --fonttype FONT # font type (default \"Verdana\")\n"
+ " --fontsize NUM # font size (default 12)\n"
+ " --countname TEXT # count type label (default \"samples\")\n"
+ " --nametype TEXT # name type label (default \"Function:\")\n"
+ " --colors PALETTE # set color palette. choices are: hot (default), mem,\n"
+ " # io, wakeup, chain, java, js, perl, red, green, blue,\n"
+ " # aqua, yellow, purple, orange\n"
+ " --hash # colors are keyed by function name hash\n"
+ " --cp # use consistent palette (palette.map)\n"
+ " --reverse # generate stack-reversed flame graph\n"
+ " --inverted # icicle graph\n"
+ " --negate # switch differential hues (blue<->red)\n"
+ " --notes TEXT # add notes comment in SVG (for debugging)\n"
+ " --help # this message\n"
+ "\n"
+ " eg,\n"
+ " $0 --title=\"Flame Graph: malloc()\" trace.txt > graph.svg\n"
+ "USAGE_END\n"
+ "}\n"
+ "\n"
+ "GetOptions(\n"
+ " 'fonttype=s' => \\$fonttype,\n"
+ " 'width=i' => \\$imagewidth,\n"
+ " 'height=i' => \\$frameheight,\n"
+ " 'encoding=s' => \\$encoding,\n"
+ " 'fontsize=f' => \\$fontsize,\n"
+ " 'fontwidth=f' => \\$fontwidth,\n"
+ " 'minwidth=f' => \\$minwidth,\n"
+ " 'title=s' => \\$titletext,\n"
+ " 'subtitle=s' => \\$subtitletext,\n"
+ " 'nametype=s' => \\$nametype,\n"
+ " 'countname=s' => \\$countname,\n"
+ " 'nameattr=s' => \\$nameattrfile,\n"
+ " 'total=s' => \\$timemax,\n"
+ " 'factor=f' => \\$factor,\n"
+ " 'colors=s' => \\$colors,\n"
+ " 'hash' => \\$hash,\n"
+ " 'cp' => \\$palette,\n"
+ " 'reverse' => \\$stackreverse,\n"
+ " 'inverted' => \\$inverted,\n"
+ " 'negate' => \\$negate,\n"
+ " 'notes=s' => \\$notestext,\n"
+ " 'help' => \\$help,\n"
+ ") or usage();\n"
+ "$help && usage();\n"
+ "\n"
+ "# internals\n"
+ "my $ypad1 = $fontsize * 3; # pad top, include title\n"
+ "my $ypad2 = $fontsize * 2 + 10; # pad bottom, include labels\n"
+ "my $ypad3 = $fontsize * 2; # pad top, include subtitle (optional)\n"
+ "my $xpad = 10; # pad lefm and right\n"
+ "my $framepad = 1; # vertical padding for frames\n"
+ "my $depthmax = 0;\n"
+ "my %Events;\n"
+ "my %nameattr;\n"
+ "\n"
+ "if ($titletext eq \"\") {\n"
+ " unless ($inverted) {\n"
+ " $titletext = $titledefault;\n"
+ " } else {\n"
+ " $titletext = $titleinverted;\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "if ($nameattrfile) {\n"
+ " # The name-attribute file format is a function name followed by a tab then\n"
+ " # a sequence of tab separated name=value pairs.\n"
+ " open my $attrfh, $nameattrfile or die \"Can't read $nameattrfile: $!\\n\";\n"
+ " while (<$attrfh>) {\n"
+ " chomp;\n"
+ " my ($funcname, $attrstr) = split /\\t/, $_, 2;\n"
+ " die \"Invalid format in $nameattrfile\" unless defined $attrstr;\n"
+ " $nameattr{$funcname} = { map { split /=/, $_, 2 } split /\\t/, $attrstr "
+ "};\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "if ($notestext =~ /[<>]/) {\n"
+ " die \"Notes string can't contain < or >\"\n"
+ "}\n"
+ "\n"
+ "# background colors:\n"
+ "# - yellow gradient: default (hot, java, js, perl)\n"
+ "# - blue gradient: mem, chain\n"
+ "# - gray gradient: io, wakeup, flat colors (red, green, blue, ...)\n"
+ "if ($colors eq \"mem\" or $colors eq \"chain\") {\n"
+ " $bgcolor1 = \"#eeeeee\"; $bgcolor2 = \"#e0e0ff\";\n"
+ "}\n"
+ "if ($colors =~ /^(io|wakeup|red|green|blue|aqua|yellow|purple|orange)$/) {\n"
+ " $bgcolor1 = \"#f8f8f8\"; $bgcolor2 = \"#e8e8e8\";\n"
+ "}\n"
+ "\n"
+ "# SVG functions\n"
+ "{ package SVG;\n"
+ " sub new {\n"
+ " my $class = shift;\n"
+ " my $self = {};\n"
+ " bless ($self, $class);\n"
+ " return $self;\n"
+ " }\n"
+ "\n"
+ " sub header {\n"
+ " my ($self, $w, $h) = @_;\n"
+ " my $enc_attr = '';\n"
+ " if (defined $encoding) {\n"
+ " $enc_attr = qq{ encoding=\"$encoding\"};\n"
+ " }\n"
+ " $self->{svg} .= <<SVG;\n"
+ "<?xml version=\"1.0\"$enc_attr standalone=\"no\"?>\n"
+ "<!DOCTYPE svg PUBLIC \"-//W3C//DTD SVG 1.1//EN\" "
+ "\"http://www.w3.org/Graphics/SVG/1.1/DTD/svg11.dtd\">\n"
+ "<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\">\n"
+ "<!-- Flame graph stack visualization. See https://github.com/brendangregg/FlameGraph "
+ "for latest version, and http://www.brendangregg.com/flamegraphs.html for examples. "
+ "-->\n"
+ "<!-- NOTES: $notestext -->\n"
+ "SVG\n"
+ " }\n"
+ "\n"
+ " sub include {\n"
+ " my ($self, $content) = @_;\n"
+ " $self->{svg} .= $content;\n"
+ " }\n"
+ "\n"
+ " sub colorAllocate {\n"
+ " my ($self, $r, $g, $b) = @_;\n"
+ " return \"rgb($r,$g,$b)\";\n"
+ " }\n"
+ "\n"
+ " sub group_start {\n"
+ " my ($self, $attr) = @_;\n"
+ "\n"
+ " my @g_attr = map {\n"
+ " exists $attr->{$_} ? sprintf(qq/$_=\"%s\"/, $attr->{$_}) : ()\n"
+ " } qw(class style onmouseover onmouseout onclick);\n"
+ " push @g_attr, $attr->{g_extra} if $attr->{g_extra};\n"
+ " $self->{svg} .= sprintf qq/<g %s>\\n/, join(' ', @g_attr);\n"
+ "\n"
+ " $self->{svg} .= sprintf qq/<title>%s<\\/title>/, $attr->{title}\n"
+ " if $attr->{title}; # should be first element within g container\n"
+ "\n"
+ " if ($attr->{href}) {\n"
+ " my @a_attr;\n"
+ " push @a_attr, sprintf qq/xlink:href=\"%s\"/, $attr->{href} if "
+ "$attr->{href};\n"
+ " # default target=_top else links will open within SVG <object>\n"
+ " push @a_attr, sprintf qq/target=\"%s\"/, $attr->{target} || "
+ "\"_top\";\n"
+ " push @a_attr, $attr->{a_extra} if "
+ "$attr->{a_extra};\n"
+ " $self->{svg} .= sprintf qq/<a %s>/, join(' ', @a_attr);\n"
+ " }\n"
+ " }\n"
+ "\n"
+ " sub group_end {\n"
+ " my ($self, $attr) = @_;\n"
+ " $self->{svg} .= qq/<\\/a>\\n/ if $attr->{href};\n"
+ " $self->{svg} .= qq/<\\/g>\\n/;\n"
+ " }\n"
+ "\n"
+ " sub filledRectangle {\n"
+ " my ($self, $x1, $y1, $x2, $y2, $fill, $extra) = @_;\n"
+ " $x1 = sprintf \"%0.1f\", $x1;\n"
+ " $x2 = sprintf \"%0.1f\", $x2;\n"
+ " my $w = sprintf \"%0.1f\", $x2 - $x1;\n"
+ " my $h = sprintf \"%0.1f\", $y2 - $y1;\n"
+ " $extra = defined $extra ? $extra : \"\";\n"
+ " $self->{svg} .= qq/<rect x=\"$x1\" y=\"$y1\" width=\"$w\" height=\"$h\" "
+ "fill=\"$fill\" $extra \\/>\\n/;\n"
+ " }\n"
+ "\n"
+ " sub stringTTF {\n"
+ " my ($self, $color, $font, $size, $angle, $x, $y, $str, $loc, $extra) = "
+ "@_;\n"
+ " $x = sprintf \"%0.2f\", $x;\n"
+ " $loc = defined $loc ? $loc : \"left\";\n"
+ " $extra = defined $extra ? $extra : \"\";\n"
+ " $self->{svg} .= qq/<text text-anchor=\"$loc\" x=\"$x\" y=\"$y\" "
+ "font-size=\"$size\" font-family=\"$font\" fill=\"$color\" $extra >$str<\\/text>\\n/;\n"
+ " }\n"
+ "\n"
+ " sub svg {\n"
+ " my $self = shift;\n"
+ " return \"$self->{svg}</svg>\\n\";\n"
+ " }\n"
+ " 1;\n"
+ "}\n"
+ "\n"
+ "sub namehash {\n"
+ " # Generate a vector hash for the name string, weighting early over\n"
+ " # later characters. We want to pick the same colors for function\n"
+ " # names across different flame graphs.\n"
+ " my $name = shift;\n"
+ " my $vector = 0;\n"
+ " my $weight = 1;\n"
+ " my $max = 1;\n"
+ " my $mod = 10;\n"
+ " # if module name present, trunc to 1st char\n"
+ " $name =~ s/.(.*?)`//;\n"
+ " foreach my $c (split //, $name) {\n"
+ " my $i = (ord $c) % $mod;\n"
+ " $vector += ($i / ($mod++ - 1)) * $weight;\n"
+ " $max += 1 * $weight;\n"
+ " $weight *= 0.70;\n"
+ " last if $mod > 12;\n"
+ " }\n"
+ " return (1 - $vector / $max)\n"
+ "}\n"
+ "\n"
+ "sub color {\n"
+ " my ($type, $hash, $name) = @_;\n"
+ " my ($v1, $v2, $v3);\n"
+ "\n"
+ " if ($hash) {\n"
+ " $v1 = namehash($name);\n"
+ " $v2 = $v3 = namehash(scalar reverse $name);\n"
+ " } else {\n"
+ " $v1 = rand(1);\n"
+ " $v2 = rand(1);\n"
+ " $v3 = rand(1);\n"
+ " }\n"
+ "\n"
+ " # theme palettes\n"
+ " if (defined $type and $type eq \"hot\") {\n"
+ " my $r = 205 + int(50 * $v3);\n"
+ " my $g = 0 + int(230 * $v1);\n"
+ " my $b = 0 + int(55 * $v2);\n"
+ " return \"rgb($r,$g,$b)\";\n"
+ " }\n"
+ " if (defined $type and $type eq \"mem\") {\n"
+ " my $r = 0;\n"
+ " my $g = 190 + int(50 * $v2);\n"
+ " my $b = 0 + int(210 * $v1);\n"
+ " return \"rgb($r,$g,$b)\";\n"
+ " }\n"
+ " if (defined $type and $type eq \"io\") {\n"
+ " my $r = 80 + int(60 * $v1);\n"
+ " my $g = $r;\n"
+ " my $b = 190 + int(55 * $v2);\n"
+ " return \"rgb($r,$g,$b)\";\n"
+ " }\n"
+ "\n"
+ " # multi palettes\n"
+ " if (defined $type and $type eq \"java\") {\n"
+ " # Handle both annotations (_[j], _[i], ...; which are\n"
+ " # accurate), as well as input that lacks any annotations, as\n"
+ " # best as possible. Without annotations, we get a little hacky\n"
+ " # and match on java|org|com, etc.\n"
+ " if ($name =~ m:_\\[j\\]$:) { # jit annotation\n"
+ " $type = \"green\";\n"
+ " } elsif ($name =~ m:_\\[i\\]$:) { # inline annotation\n"
+ " $type = \"aqua\";\n"
+ " } elsif ($name =~ m:^L?(java|org|com|io|sun)/:) { # Java\n"
+ " $type = \"green\";\n"
+ " } elsif ($name =~ /::/) { # C++\n"
+ " $type = \"yellow\";\n"
+ " } elsif ($name =~ m:_\\[k\\]$:) { # kernel annotation\n"
+ " $type = \"orange\";\n"
+ " } else { # system\n"
+ " $type = \"red\";\n"
+ " }\n"
+ " # fall-through to color palettes\n"
+ " }\n"
+ " if (defined $type and $type eq \"perl\") {\n"
+ " if ($name =~ /::/) { # C++\n"
+ " $type = \"yellow\";\n"
+ " } elsif ($name =~ m:Perl: or $name =~ m:\\.pl:) { # Perl\n"
+ " $type = \"green\";\n"
+ " } elsif ($name =~ m:_\\[k\\]$:) { # kernel\n"
+ " $type = \"orange\";\n"
+ " } else { # system\n"
+ " $type = \"red\";\n"
+ " }\n"
+ " # fall-through to color palettes\n"
+ " }\n"
+ " if (defined $type and $type eq \"js\") {\n"
+ " # Handle both annotations (_[j], _[i], ...; which are\n"
+ " # accurate), as well as input that lacks any annotations, as\n"
+ " # best as possible. Without annotations, we get a little hacky,\n"
+ " # and match on a \"/\" with a \".js\", etc.\n"
+ " if ($name =~ m:_\\[j\\]$:) { # jit annotation\n"
+ " if ($name =~ m:/:) {\n"
+ " $type = \"green\"; # source\n"
+ " } else {\n"
+ " $type = \"aqua\"; # builtin\n"
+ " }\n"
+ " } elsif ($name =~ /::/) { # C++\n"
+ " $type = \"yellow\";\n"
+ " } elsif ($name =~ m:/.*\\.js:) { # JavaScript (match \"/\" in "
+ "path)\n"
+ " $type = \"green\";\n"
+ " } elsif ($name =~ m/:/) { # JavaScript (match \":\" in builtin)\n"
+ " $type = \"aqua\";\n"
+ " } elsif ($name =~ m/^ $/) { # Missing symbol\n"
+ " $type = \"green\";\n"
+ " } elsif ($name =~ m:_\\[k\\]:) { # kernel\n"
+ " $type = \"orange\";\n"
+ " } else { # system\n"
+ " $type = \"red\";\n"
+ " }\n"
+ " # fall-through to color palettes\n"
+ " }\n"
+ " if (defined $type and $type eq \"wakeup\") {\n"
+ " $type = \"aqua\";\n"
+ " # fall-through to color palettes\n"
+ " }\n"
+ " if (defined $type and $type eq \"chain\") {\n"
+ " if ($name =~ m:_\\[w\\]:) { # waker\n"
+ " $type = \"aqua\"\n"
+ " } else { # off-CPU\n"
+ " $type = \"blue\";\n"
+ " }\n"
+ " # fall-through to color palettes\n"
+ " }\n"
+ "\n"
+ " # color palettes\n"
+ " if (defined $type and $type eq \"red\") {\n"
+ " my $r = 200 + int(55 * $v1);\n"
+ " my $x = 50 + int(80 * $v1);\n"
+ " return \"rgb($r,$x,$x)\";\n"
+ " }\n"
+ " if (defined $type and $type eq \"green\") {\n"
+ " my $g = 200 + int(55 * $v1);\n"
+ " my $x = 50 + int(60 * $v1);\n"
+ " return \"rgb($x,$g,$x)\";\n"
+ " }\n"
+ " if (defined $type and $type eq \"blue\") {\n"
+ " my $b = 205 + int(50 * $v1);\n"
+ " my $x = 80 + int(60 * $v1);\n"
+ " return \"rgb($x,$x,$b)\";\n"
+ " }\n"
+ " if (defined $type and $type eq \"yellow\") {\n"
+ " my $x = 175 + int(55 * $v1);\n"
+ " my $b = 50 + int(20 * $v1);\n"
+ " return \"rgb($x,$x,$b)\";\n"
+ " }\n"
+ " if (defined $type and $type eq \"purple\") {\n"
+ " my $x = 190 + int(65 * $v1);\n"
+ " my $g = 80 + int(60 * $v1);\n"
+ " return \"rgb($x,$g,$x)\";\n"
+ " }\n"
+ " if (defined $type and $type eq \"aqua\") {\n"
+ " my $r = 50 + int(60 * $v1);\n"
+ " my $g = 165 + int(55 * $v1);\n"
+ " my $b = 165 + int(55 * $v1);\n"
+ " return \"rgb($r,$g,$b)\";\n"
+ " }\n"
+ " if (defined $type and $type eq \"orange\") {\n"
+ " my $r = 190 + int(65 * $v1);\n"
+ " my $g = 90 + int(65 * $v1);\n"
+ " return \"rgb($r,$g,0)\";\n"
+ " }\n"
+ "\n"
+ " return \"rgb(0,0,0)\";\n"
+ "}\n"
+ "\n"
+ "sub color_scale {\n"
+ " my ($value, $max) = @_;\n"
+ " my ($r, $g, $b) = (255, 255, 255);\n"
+ " $value = -$value if $negate;\n"
+ " if ($value > 0) {\n"
+ " $g = $b = int(210 * ($max - $value) / $max);\n"
+ " } elsif ($value < 0) {\n"
+ " $r = $g = int(210 * ($max + $value) / $max);\n"
+ " }\n"
+ " return \"rgb($r,$g,$b)\";\n"
+ "}\n"
+ "\n"
+ "sub color_map {\n"
+ " my ($colors, $func) = @_;\n"
+ " if (exists $palette_map{$func}) {\n"
+ " return $palette_map{$func};\n"
+ " } else {\n"
+ " $palette_map{$func} = color($colors, $hash, $func);\n"
+ " return $palette_map{$func};\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "sub write_palette {\n"
+ " open(FILE, \">$pal_file\");\n"
+ " foreach my $key (sort keys %palette_map) {\n"
+ " print FILE $key.\"->\".$palette_map{$key}.\"\\n\";\n"
+ " }\n"
+ " close(FILE);\n"
+ "}\n"
+ "\n"
+ "sub read_palette {\n"
+ " if (-e $pal_file) {\n"
+ " open(FILE, $pal_file) or die \"can't open file $pal_file: $!\";\n"
+ " while ( my $line = <FILE>) {\n"
+ " chomp($line);\n"
+ " (my $key, my $value) = split(\"->\",$line);\n"
+ " $palette_map{$key}=$value;\n"
+ " }\n"
+ " close(FILE)\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "my %Node; # Hash of merged frame data\n"
+ "my %Tmp;\n"
+ "\n"
+ "# flow() merges two stacks, storing the merged frames and value data in %Node.\n"
+ "sub flow {\n"
+ " my ($last, $this, $v, $d) = @_;\n"
+ "\n"
+ " my $len_a = @$last - 1;\n"
+ " my $len_b = @$this - 1;\n"
+ "\n"
+ " my $i = 0;\n"
+ " my $len_same;\n"
+ " for (; $i <= $len_a; $i++) {\n"
+ " last if $i > $len_b;\n"
+ " last if $last->[$i] ne $this->[$i];\n"
+ " }\n"
+ " $len_same = $i;\n"
+ "\n"
+ " for ($i = $len_a; $i >= $len_same; $i--) {\n"
+ " my $k = \"$last->[$i];$i\";\n"
+ " # a unique ID is constructed from \"func;depth;etime\";\n"
+ " # func-depth isn't unique, it may be repeated later.\n"
+ " $Node{\"$k;$v\"}->{stime} = delete $Tmp{$k}->{stime};\n"
+ " if (defined $Tmp{$k}->{delta}) {\n"
+ " $Node{\"$k;$v\"}->{delta} = delete $Tmp{$k}->{delta};\n"
+ " }\n"
+ " delete $Tmp{$k};\n"
+ " }\n"
+ "\n"
+ " for ($i = $len_same; $i <= $len_b; $i++) {\n"
+ " my $k = \"$this->[$i];$i\";\n"
+ " $Tmp{$k}->{stime} = $v;\n"
+ " if (defined $d) {\n"
+ " $Tmp{$k}->{delta} += $i == $len_b ? $d : 0;\n"
+ " }\n"
+ " }\n"
+ "\n"
+ " return $this;\n"
+ "}\n"
+ "\n"
+ "# parse input\n"
+ "my @Data;\n"
+ "my $last = [];\n"
+ "my $time = 0;\n"
+ "my $delta = undef;\n"
+ "my $ignored = 0;\n"
+ "my $line;\n"
+ "my $maxdelta = 1;\n"
+ "\n"
+ "# reverse if needed\n"
+ "foreach (<>) {\n"
+ " chomp;\n"
+ " $line = $_;\n"
+ " if ($stackreverse) {\n"
+ " # there may be an extra samples column for differentials\n"
+ " # XXX todo: redo these REs as one. It's repeated below.\n"
+ " my($stack, $samples) = (/^(.*)\\s+?(\\d+(?:\\.\\d*)?)$/);\n"
+ " my $samples2 = undef;\n"
+ " if ($stack =~ /^(.*)\\s+?(\\d+(?:\\.\\d*)?)$/) {\n"
+ " $samples2 = $samples;\n"
+ " ($stack, $samples) = $stack =~ (/^(.*)\\s+?(\\d+(?:\\.\\d*)?)$/);\n"
+ " unshift @Data, join(\";\", reverse split(\";\", $stack)) . \" "
+ "$samples $samples2\";\n"
+ " } else {\n"
+ " unshift @Data, join(\";\", reverse split(\";\", $stack)) . \" "
+ "$samples\";\n"
+ " }\n"
+ " } else {\n"
+ " unshift @Data, $line;\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "# process and merge frames\n"
+ "foreach (sort @Data) {\n"
+ " chomp;\n"
+ " # process: folded_stack count\n"
+ " # eg: func_a;func_b;func_c 31\n"
+ " my ($stack, $samples) = (/^(.*)\\s+?(\\d+(?:\\.\\d*)?)$/);\n"
+ " unless (defined $samples and defined $stack) {\n"
+ " ++$ignored;\n"
+ " next;\n"
+ " }\n"
+ "\n"
+ " # there may be an extra samples column for differentials:\n"
+ " my $samples2 = undef;\n"
+ " if ($stack =~ /^(.*)\\s+?(\\d+(?:\\.\\d*)?)$/) {\n"
+ " $samples2 = $samples;\n"
+ " ($stack, $samples) = $stack =~ (/^(.*)\\s+?(\\d+(?:\\.\\d*)?)$/);\n"
+ " }\n"
+ " $delta = undef;\n"
+ " if (defined $samples2) {\n"
+ " $delta = $samples2 - $samples;\n"
+ " $maxdelta = abs($delta) if abs($delta) > $maxdelta;\n"
+ " }\n"
+ "\n"
+ " # for chain graphs, annotate waker frames with \"_[w]\", for later\n"
+ " # coloring. This is a hack, but has a precedent (\"_[k]\" from perf).\n"
+ " if ($colors eq \"chain\") {\n"
+ " my @parts = split \";--;\", $stack;\n"
+ " my @newparts = ();\n"
+ " $stack = shift @parts;\n"
+ " $stack .= \";--;\";\n"
+ " foreach my $part (@parts) {\n"
+ " $part =~ s/;/_[w];/g;\n"
+ " $part .= \"_[w]\";\n"
+ " push @newparts, $part;\n"
+ " }\n"
+ " $stack .= join \";--;\", @parts;\n"
+ " }\n"
+ "\n"
+ " # merge frames and populate %Node:\n"
+ " $last = flow($last, [ '', split \";\", $stack ], $time, $delta);\n"
+ "\n"
+ " if (defined $samples2) {\n"
+ " $time += $samples2;\n"
+ " } else {\n"
+ " $time += $samples;\n"
+ " }\n"
+ "}\n"
+ "flow($last, [], $time, $delta);\n"
+ "\n"
+ "warn \"Ignored $ignored lines with invalid format\\n\" if $ignored;\n"
+ "unless ($time) {\n"
+ " warn \"ERROR: No stack counts found\\n\";\n"
+ " my $im = SVG->new();\n"
+ " # emit an error message SVG, for tools automating flamegraph use\n"
+ " my $imageheight = $fontsize * 5;\n"
+ " $im->header($imagewidth, $imageheight);\n"
+ " $im->stringTTF($im->colorAllocate(0, 0, 0), $fonttype, $fontsize + 2,\n"
+ " 0.0, int($imagewidth / 2), $fontsize * 2,\n"
+ " \"ERROR: No valid input provided to flamegraph.pl.\", \"middle\");\n"
+ " print $im->svg;\n"
+ " exit 2;\n"
+ "}\n"
+ "if ($timemax and $timemax < $time) {\n"
+ " warn \"Specified --total $timemax is less than actual total $time, so "
+ "ignored\\n\"\n"
+ " if $timemax/$time > 0.02; # only warn is significant (e.g., not rounding etc)\n"
+ " undef $timemax;\n"
+ "}\n"
+ "$timemax ||= $time;\n"
+ "\n"
+ "my $widthpertime = ($imagewidth - 2 * $xpad) / $timemax;\n"
+ "my $minwidth_time = $minwidth / $widthpertime;\n"
+ "\n"
+ "# prune blocks that are too narrow and determine max depth\n"
+ "while (my ($id, $node) = each %Node) {\n"
+ " my ($func, $depth, $etime) = split \";\", $id;\n"
+ " my $stime = $node->{stime};\n"
+ " die \"missing start for $id\" if not defined $stime;\n"
+ "\n"
+ " if (($etime-$stime) < $minwidth_time) {\n"
+ " delete $Node{$id};\n"
+ " next;\n"
+ " }\n"
+ " $depthmax = $depth if $depth > $depthmax;\n"
+ "}\n"
+ "\n"
+ "# draw canvas, and embed interactive JavaScript program\n"
+ "my $imageheight = (($depthmax + 1) * $frameheight) + $ypad1 + $ypad2;\n"
+ "$imageheight += $ypad3 if $subtitletext ne \"\";\n"
+ "my $im = SVG->new();\n"
+ "$im->header($imagewidth, $imageheight);\n"
+ "my $inc = <<INC;\n"
+ "<defs >\n"
+ " <linearGradient id=\"background\" y1=\"0\" y2=\"1\" x1=\"0\" x2=\"0\" >\n"
+ " <stop stop-color=\"$bgcolor1\" offset=\"5%\" />\n"
+ " <stop stop-color=\"$bgcolor2\" offset=\"95%\" />\n"
+ " </linearGradient>\n"
+ "</defs>\n"
+ "<style type=\"text/css\">\n"
+ " .func_g:hover { stroke:black; stroke-width:0.5; cursor:pointer; }\n"
+ "</style>\n"
+ "<script type=\"text/ecmascript\">\n"
+ "<![CDATA[\n"
+ " var details, searchbtn, matchedtxt, svg;\n"
+ " function init(evt) {\n"
+ " details = document.getElementById(\"details\").firstChild;\n"
+ " searchbtn = document.getElementById(\"search\");\n"
+ " matchedtxt = document.getElementById(\"matched\");\n"
+ " svg = document.getElementsByTagName(\"svg\")[0];\n"
+ " searching = 0;\n"
+ " }\n"
+ "\n"
+ " // mouse-over for info\n"
+ " function s(node) { // show\n"
+ " info = g_to_text(node);\n"
+ " details.nodeValue = \"$nametype \" + info;\n"
+ " }\n"
+ " function c() { // clear\n"
+ " details.nodeValue = ' ';\n"
+ " }\n"
+ "\n"
+ " // ctrl-F for search\n"
+ " window.addEventListener(\"keydown\",function (e) {\n"
+ " if (e.keyCode === 114 || (e.ctrlKey && e.keyCode === 70)) {\n"
+ " e.preventDefault();\n"
+ " search_prompt();\n"
+ " }\n"
+ " })\n"
+ "\n"
+ " // functions\n"
+ " function find_child(parent, name, attr) {\n"
+ " var children = parent.childNodes;\n"
+ " for (var i=0; i<children.length;i++) {\n"
+ " if (children[i].tagName == name)\n"
+ " return (attr != undefined) ? "
+ "children[i].attributes[attr].value : children[i];\n"
+ " }\n"
+ " return;\n"
+ " }\n"
+ " function orig_save(e, attr, val) {\n"
+ " if (e.attributes[\"_orig_\"+attr] != undefined) return;\n"
+ " if (e.attributes[attr] == undefined) return;\n"
+ " if (val == undefined) val = e.attributes[attr].value;\n"
+ " e.setAttribute(\"_orig_\"+attr, val);\n"
+ " }\n"
+ " function orig_load(e, attr) {\n"
+ " if (e.attributes[\"_orig_\"+attr] == undefined) return;\n"
+ " e.attributes[attr].value = e.attributes[\"_orig_\"+attr].value;\n"
+ " e.removeAttribute(\"_orig_\"+attr);\n"
+ " }\n"
+ " function g_to_text(e) {\n"
+ " var text = find_child(e, \"title\").firstChild.nodeValue;\n"
+ " return (text)\n"
+ " }\n"
+ " function g_to_func(e) {\n"
+ " var func = g_to_text(e);\n"
+ " // if there's any manipulation we want to do to the function\n"
+ " // name before it's searched, do it here before returning.\n"
+ " return (func);\n"
+ " }\n"
+ " function update_text(e) {\n"
+ " var r = find_child(e, \"rect\");\n"
+ " var t = find_child(e, \"text\");\n"
+ " var w = parseFloat(r.attributes[\"width\"].value) -3;\n"
+ " var txt = find_child(e, "
+ "\"title\").textContent.replace(/\\\\([^(]*\\\\)\\$/,\"\");\n"
+ " t.attributes[\"x\"].value = parseFloat(r.attributes[\"x\"].value) +3;\n"
+ "\n"
+ " // Smaller than this size won't fit anything\n"
+ " if (w < 2*$fontsize*$fontwidth) {\n"
+ " t.textContent = \"\";\n"
+ " return;\n"
+ " }\n"
+ "\n"
+ " t.textContent = txt;\n"
+ " // Fit in full text width\n"
+ " if (/^ *\\$/.test(txt) || t.getSubStringLength(0, txt.length) < w)\n"
+ " return;\n"
+ "\n"
+ " for (var x=txt.length-2; x>0; x--) {\n"
+ " if (t.getSubStringLength(0, x+2) <= w) {\n"
+ " t.textContent = txt.substring(0,x) + \"..\";\n"
+ " return;\n"
+ " }\n"
+ " }\n"
+ " t.textContent = \"\";\n"
+ " }\n"
+ "\n"
+ " // zoom\n"
+ " function zoom_reset(e) {\n"
+ " if (e.attributes != undefined) {\n"
+ " orig_load(e, \"x\");\n"
+ " orig_load(e, \"width\");\n"
+ " }\n"
+ " if (e.childNodes == undefined) return;\n"
+ " for(var i=0, c=e.childNodes; i<c.length; i++) {\n"
+ " zoom_reset(c[i]);\n"
+ " }\n"
+ " }\n"
+ " function zoom_child(e, x, ratio) {\n"
+ " if (e.attributes != undefined) {\n"
+ " if (e.attributes[\"x\"] != undefined) {\n"
+ " orig_save(e, \"x\");\n"
+ " e.attributes[\"x\"].value = "
+ "(parseFloat(e.attributes[\"x\"].value) - x - $xpad) * ratio + $xpad;\n"
+ " if(e.tagName == \"text\") e.attributes[\"x\"].value = "
+ "find_child(e.parentNode, \"rect\", \"x\") + 3;\n"
+ " }\n"
+ " if (e.attributes[\"width\"] != undefined) {\n"
+ " orig_save(e, \"width\");\n"
+ " e.attributes[\"width\"].value = "
+ "parseFloat(e.attributes[\"width\"].value) * ratio;\n"
+ " }\n"
+ " }\n"
+ "\n"
+ " if (e.childNodes == undefined) return;\n"
+ " for(var i=0, c=e.childNodes; i<c.length; i++) {\n"
+ " zoom_child(c[i], x-$xpad, ratio);\n"
+ " }\n"
+ " }\n"
+ " function zoom_parent(e) {\n"
+ " if (e.attributes) {\n"
+ " if (e.attributes[\"x\"] != undefined) {\n"
+ " orig_save(e, \"x\");\n"
+ " e.attributes[\"x\"].value = $xpad;\n"
+ " }\n"
+ " if (e.attributes[\"width\"] != undefined) {\n"
+ " orig_save(e, \"width\");\n"
+ " e.attributes[\"width\"].value = "
+ "parseInt(svg.width.baseVal.value) - ($xpad*2);\n"
+ " }\n"
+ " }\n"
+ " if (e.childNodes == undefined) return;\n"
+ " for(var i=0, c=e.childNodes; i<c.length; i++) {\n"
+ " zoom_parent(c[i]);\n"
+ " }\n"
+ " }\n"
+ " function zoom(node) {\n"
+ " var attr = find_child(node, \"rect\").attributes;\n"
+ " var width = parseFloat(attr[\"width\"].value);\n"
+ " var xmin = parseFloat(attr[\"x\"].value);\n"
+ " var xmax = parseFloat(xmin + width);\n"
+ " var ymin = parseFloat(attr[\"y\"].value);\n"
+ " var ratio = (svg.width.baseVal.value - 2*$xpad) / width;\n"
+ "\n"
+ " // XXX: Workaround for JavaScript float issues (fix me)\n"
+ " var fudge = 0.0001;\n"
+ "\n"
+ " var unzoombtn = document.getElementById(\"unzoom\");\n"
+ " unzoombtn.style[\"opacity\"] = \"1.0\";\n"
+ "\n"
+ " var el = document.getElementsByTagName(\"g\");\n"
+ " for(var i=0;i<el.length;i++){\n"
+ " var e = el[i];\n"
+ " var a = find_child(e, \"rect\").attributes;\n"
+ " var ex = parseFloat(a[\"x\"].value);\n"
+ " var ew = parseFloat(a[\"width\"].value);\n"
+ " // Is it an ancestor\n"
+ " if ($inverted == 0) {\n"
+ " var upstack = parseFloat(a[\"y\"].value) > ymin;\n"
+ " } else {\n"
+ " var upstack = parseFloat(a[\"y\"].value) < ymin;\n"
+ " }\n"
+ " if (upstack) {\n"
+ " // Direct ancestor\n"
+ " if (ex <= xmin && (ex+ew+fudge) >= xmax) {\n"
+ " e.style[\"opacity\"] = \"0.5\";\n"
+ " zoom_parent(e);\n"
+ " e.onclick = function(e){unzoom(); zoom(this);};\n"
+ " update_text(e);\n"
+ " }\n"
+ " // not in current path\n"
+ " else\n"
+ " e.style[\"display\"] = \"none\";\n"
+ " }\n"
+ " // Children maybe\n"
+ " else {\n"
+ " // no common path\n"
+ " if (ex < xmin || ex + fudge >= xmax) {\n"
+ " e.style[\"display\"] = \"none\";\n"
+ " }\n"
+ " else {\n"
+ " zoom_child(e, xmin, ratio);\n"
+ " e.onclick = function(e){zoom(this);};\n"
+ " update_text(e);\n"
+ " }\n"
+ " }\n"
+ " }\n"
+ " }\n"
+ " function unzoom() {\n"
+ " var unzoombtn = document.getElementById(\"unzoom\");\n"
+ " unzoombtn.style[\"opacity\"] = \"0.0\";\n"
+ "\n"
+ " var el = document.getElementsByTagName(\"g\");\n"
+ " for(i=0;i<el.length;i++) {\n"
+ " el[i].style[\"display\"] = \"block\";\n"
+ " el[i].style[\"opacity\"] = \"1\";\n"
+ " zoom_reset(el[i]);\n"
+ " update_text(el[i]);\n"
+ " }\n"
+ " }\n"
+ "\n"
+ " // search\n"
+ " function reset_search() {\n"
+ " var el = document.getElementsByTagName(\"rect\");\n"
+ " for (var i=0; i < el.length; i++) {\n"
+ " orig_load(el[i], \"fill\")\n"
+ " }\n"
+ " }\n"
+ " function search_prompt() {\n"
+ " if (!searching) {\n"
+ " var term = prompt(\"Enter a search term (regexp \" +\n"
+ " \"allowed, eg: ^ext4_)\", \"\");\n"
+ " if (term != null) {\n"
+ " search(term)\n"
+ " }\n"
+ " } else {\n"
+ " reset_search();\n"
+ " searching = 0;\n"
+ " searchbtn.style[\"opacity\"] = \"0.1\";\n"
+ " searchbtn.firstChild.nodeValue = \"Search\"\n"
+ " matchedtxt.style[\"opacity\"] = \"0.0\";\n"
+ " matchedtxt.firstChild.nodeValue = \"\"\n"
+ " }\n"
+ " }\n"
+ " function search(term) {\n"
+ " var re = new RegExp(term);\n"
+ " var el = document.getElementsByTagName(\"g\");\n"
+ " var matches = new Object();\n"
+ " var maxwidth = 0;\n"
+ " for (var i = 0; i < el.length; i++) {\n"
+ " var e = el[i];\n"
+ " if (e.attributes[\"class\"].value != \"func_g\")\n"
+ " continue;\n"
+ " var func = g_to_func(e);\n"
+ " var rect = find_child(e, \"rect\");\n"
+ " if (rect == null) {\n"
+ " // the rect might be wrapped in an anchor\n"
+ " // if nameattr href is being used\n"
+ " if (rect = find_child(e, \"a\")) {\n"
+ " rect = find_child(r, \"rect\");\n"
+ " }\n"
+ " }\n"
+ " if (func == null || rect == null)\n"
+ " continue;\n"
+ "\n"
+ " // Save max width. Only works as we have a root frame\n"
+ " var w = parseFloat(rect.attributes[\"width\"].value);\n"
+ " if (w > maxwidth)\n"
+ " maxwidth = w;\n"
+ "\n"
+ " if (func.match(re)) {\n"
+ " // highlight\n"
+ " var x = parseFloat(rect.attributes[\"x\"].value);\n"
+ " orig_save(rect, \"fill\");\n"
+ " rect.attributes[\"fill\"].value =\n"
+ " \"$searchcolor\";\n"
+ "\n"
+ " // remember matches\n"
+ " if (matches[x] == undefined) {\n"
+ " matches[x] = w;\n"
+ " } else {\n"
+ " if (w > matches[x]) {\n"
+ " // overwrite with parent\n"
+ " matches[x] = w;\n"
+ " }\n"
+ " }\n"
+ " searching = 1;\n"
+ " }\n"
+ " }\n"
+ " if (!searching)\n"
+ " return;\n"
+ "\n"
+ " searchbtn.style[\"opacity\"] = \"1.0\";\n"
+ " searchbtn.firstChild.nodeValue = \"Reset Search\"\n"
+ "\n"
+ " // calculate percent matched, excluding vertical overlap\n"
+ " var count = 0;\n"
+ " var lastx = -1;\n"
+ " var lastw = 0;\n"
+ " var keys = Array();\n"
+ " for (k in matches) {\n"
+ " if (matches.hasOwnProperty(k))\n"
+ " keys.push(k);\n"
+ " }\n"
+ " // sort the matched frames by their x location\n"
+ " // ascending, then width descending\n"
+ " keys.sort(function(a, b){\n"
+ " return a - b;\n"
+ " });\n"
+ " // Step through frames saving only the biggest bottom-up frames\n"
+ " // thanks to the sort order. This relies on the tree property\n"
+ " // where children are always smaller than their parents.\n"
+ " var fudge = 0.0001; // JavaScript floating point\n"
+ " for (var k in keys) {\n"
+ " var x = parseFloat(keys[k]);\n"
+ " var w = matches[keys[k]];\n"
+ " if (x >= lastx + lastw - fudge) {\n"
+ " count += w;\n"
+ " lastx = x;\n"
+ " lastw = w;\n"
+ " }\n"
+ " }\n"
+ " // display matched percent\n"
+ " matchedtxt.style[\"opacity\"] = \"1.0\";\n"
+ " pct = 100 * count / maxwidth;\n"
+ " if (pct == 100)\n"
+ " pct = \"100\"\n"
+ " else\n"
+ " pct = pct.toFixed(1)\n"
+ " matchedtxt.firstChild.nodeValue = \"Matched: \" + pct + \"%\";\n"
+ " }\n"
+ " function searchover(e) {\n"
+ " searchbtn.style[\"opacity\"] = \"1.0\";\n"
+ " }\n"
+ " function searchout(e) {\n"
+ " if (searching) {\n"
+ " searchbtn.style[\"opacity\"] = \"1.0\";\n"
+ " } else {\n"
+ " searchbtn.style[\"opacity\"] = \"0.1\";\n"
+ " }\n"
+ " }\n"
+ "]]>\n"
+ "</script>\n"
+ "INC\n"
+ "$im->include($inc);\n"
+ "$im->filledRectangle(0, 0, $imagewidth, $imageheight, 'url(#background)');\n"
+ "my ($white, $black, $vvdgrey, $vdgrey, $dgrey) = (\n"
+ " $im->colorAllocate(255, 255, 255),\n"
+ " $im->colorAllocate(0, 0, 0),\n"
+ " $im->colorAllocate(40, 40, 40),\n"
+ " $im->colorAllocate(160, 160, 160),\n"
+ " $im->colorAllocate(200, 200, 200),\n"
+ " );\n"
+ "$im->stringTTF($black, $fonttype, $fontsize + 5, 0.0, int($imagewidth / 2), $fontsize "
+ "* 2, $titletext, \"middle\");\n"
+ "if ($subtitletext ne \"\") {\n"
+ " $im->stringTTF($vdgrey, $fonttype, $fontsize, 0.0, int($imagewidth / 2), $fontsize "
+ "* 4, $subtitletext, \"middle\");\n"
+ "}\n"
+ "$im->stringTTF($black, $fonttype, $fontsize, 0.0, $xpad, $imageheight - ($ypad2 / 2), "
+ "\" \", \"\", 'id=\"details\"');\n"
+ "$im->stringTTF($black, $fonttype, $fontsize, 0.0, $xpad, $fontsize * 2,\n"
+ " \"Reset Zoom\", \"\", 'id=\"unzoom\" onclick=\"unzoom()\" "
+ "style=\"opacity:0.0;cursor:pointer\"');\n"
+ "$im->stringTTF($black, $fonttype, $fontsize, 0.0, $imagewidth - $xpad - 100,\n"
+ " $fontsize * 2, \"Search\", \"\", 'id=\"search\" onmouseover=\"searchover()\" "
+ "onmouseout=\"searchout()\" onclick=\"search_prompt()\" "
+ "style=\"opacity:0.1;cursor:pointer\"');\n"
+ "$im->stringTTF($black, $fonttype, $fontsize, 0.0, $imagewidth - $xpad - 100, "
+ "$imageheight - ($ypad2 / 2), \" \", \"\", 'id=\"matched\"');\n"
+ "\n"
+ "if ($palette) {\n"
+ " read_palette();\n"
+ "}\n"
+ "\n"
+ "# draw frames\n"
+ "while (my ($id, $node) = each %Node) {\n"
+ " my ($func, $depth, $etime) = split \";\", $id;\n"
+ " my $stime = $node->{stime};\n"
+ " my $delta = $node->{delta};\n"
+ "\n"
+ " $etime = $timemax if $func eq \"\" and $depth == 0;\n"
+ "\n"
+ " my $x1 = $xpad + $stime * $widthpertime;\n"
+ " my $x2 = $xpad + $etime * $widthpertime;\n"
+ " my ($y1, $y2);\n"
+ " unless ($inverted) {\n"
+ " $y1 = $imageheight - $ypad2 - ($depth + 1) * $frameheight + $framepad;\n"
+ " $y2 = $imageheight - $ypad2 - $depth * $frameheight;\n"
+ " } else {\n"
+ " $y1 = $ypad1 + $depth * $frameheight;\n"
+ " $y2 = $ypad1 + ($depth + 1) * $frameheight - $framepad;\n"
+ " }\n"
+ "\n"
+ " my $samples = sprintf \"%.0f\", ($etime - $stime) * $factor;\n"
+ " (my $samples_txt = $samples) # add commas per perlfaq5\n"
+ " =~ s/(^[-+]?\\d+?(?=(?>(?:\\d{3})+)(?!\\d))|\\G\\d{3}(?=\\d))/$1,/g;\n"
+ "\n"
+ " my $info;\n"
+ " if ($func eq \"\" and $depth == 0) {\n"
+ " $info = \"all ($samples_txt $countname, 100%)\";\n"
+ " } else {\n"
+ " my $pct = sprintf \"%.2f\", ((100 * $samples) / ($timemax * $factor));\n"
+ " my $escaped_func = $func;\n"
+ " # clean up SVG breaking characters:\n"
+ " $escaped_func =~ s/&/&/g;\n"
+ " $escaped_func =~ s/</</g;\n"
+ " $escaped_func =~ s/>/>/g;\n"
+ " $escaped_func =~ s/\"/"/g;\n"
+ " $escaped_func =~ s/_\\[[kwij]\\]$//; # strip any annotation\n"
+ " unless (defined $delta) {\n"
+ " $info = \"$escaped_func ($samples_txt $countname, $pct%)\";\n"
+ " } else {\n"
+ " my $d = $negate ? -$delta : $delta;\n"
+ " my $deltapct = sprintf \"%.2f\", ((100 * $d) / ($timemax * "
+ "$factor));\n"
+ " $deltapct = $d > 0 ? \"+$deltapct\" : $deltapct;\n"
+ " $info = \"$escaped_func ($samples_txt $countname, $pct%; "
+ "$deltapct%)\";\n"
+ " }\n"
+ " }\n"
+ "\n"
+ " my $nameattr = { %{ $nameattr{$func}||{} } }; # shallow clone\n"
+ " $nameattr->{class} ||= \"func_g\";\n"
+ " $nameattr->{onmouseover} ||= \"s(this)\";\n"
+ " $nameattr->{onmouseout} ||= \"c()\";\n"
+ " $nameattr->{onclick} ||= \"zoom(this)\";\n"
+ " $nameattr->{title} ||= $info;\n"
+ " $im->group_start($nameattr);\n"
+ "\n"
+ " my $color;\n"
+ " if ($func eq \"--\") {\n"
+ " $color = $vdgrey;\n"
+ " } elsif ($func eq \"-\") {\n"
+ " $color = $dgrey;\n"
+ " } elsif (defined $delta) {\n"
+ " $color = color_scale($delta, $maxdelta);\n"
+ " } elsif ($palette) {\n"
+ " $color = color_map($colors, $func);\n"
+ " } else {\n"
+ " $color = color($colors, $hash, $func);\n"
+ " }\n"
+ " $im->filledRectangle($x1, $y1, $x2, $y2, $color, 'rx=\"2\" ry=\"2\"');\n"
+ "\n"
+ " my $chars = int( ($x2 - $x1) / ($fontsize * $fontwidth));\n"
+ " my $text = \"\";\n"
+ " if ($chars >= 3) { # room for one char plus two dots\n"
+ " $func =~ s/_\\[[kwij]\\]$//; # strip any annotation\n"
+ " $text = substr $func, 0, $chars;\n"
+ " substr($text, -2, 2) = \"..\" if $chars < length $func;\n"
+ " $text =~ s/&/&/g;\n"
+ " $text =~ s/</</g;\n"
+ " $text =~ s/>/>/g;\n"
+ " }\n"
+ " $im->stringTTF($black, $fonttype, $fontsize, 0.0, $x1 + 3, 3 + ($y1 + $y2) / 2, "
+ "$text, \"\");\n"
+ "\n"
+ " $im->group_end($nameattr);\n"
+ "}\n"
+ "\n"
+ "print $im->svg;\n"
+ "\n"
+ "if ($palette) {\n"
+ " write_palette();\n"
+ "}\n";
+}
+
+} // namespace brpc
diff --git a/src/brpc/builtin/flamegraph_perl.h b/src/brpc/builtin/flamegraph_perl.h
new file mode 100644
index 0000000..406cc56
--- /dev/null
+++ b/src/brpc/builtin/flamegraph_perl.h
@@ -0,0 +1,25 @@
+// Licensed to the Apache Software Foundation (ASF) under one
+// or more contributor license agreements. See the NOTICE file
+// distributed with this work for additional information
+// regarding copyright ownership. The ASF licenses this file
+// to you under the Apache License, Version 2.0 (the
+// "License"); you may not use this file except in compliance
+// with the License. You may obtain a copy of the License at
+//
+// http://www.apache.org/licenses/LICENSE-2.0
+//
+// Unless required by applicable law or agreed to in writing,
+// software distributed under the License is distributed on an
+// "AS IS" BASIS, WITHOUT WARRANTIES OR CONDITIONS OF ANY
+// KIND, either express or implied. See the License for the
+// specific language governing permissions and limitations
+// under the License.
+// Authors: Tian,Ye (tianye15@baidu.com)
+
+#pragma once
+
+namespace brpc {
+
+const char* flamegraph_perl();
+
+} // namespace brpc
diff --git a/src/brpc/builtin/hotspots_service.cpp b/src/brpc/builtin/hotspots_service.cpp
index 3764f93..a1eeb83 100644
--- a/src/brpc/builtin/hotspots_service.cpp
+++ b/src/brpc/builtin/hotspots_service.cpp
@@ -16,8 +16,10 @@
// under the License.
// Authors: Ge,Jun (gejun@baidu.com)
+// Tian,Ye(tianye15@baidu.com)
#include <stdio.h>
+#include <thread>
#include <gflags/gflags.h>
#include "butil/files/file_enumerator.h"
#include "butil/file_util.h" // butil::FilePath
@@ -28,6 +30,7 @@
#include "brpc/server.h"
#include "brpc/reloadable_flags.h"
#include "brpc/builtin/pprof_perl.h"
+#include "brpc/builtin/flamegraph_perl.h"
#include "brpc/builtin/hotspots_service.h"
#include "brpc/details/tcmalloc_extension.h"
@@ -43,6 +46,67 @@ void ContentionProfilerStop();
namespace brpc {
+enum class DisplayType{
+ kUnknown,
+#if defined(OS_LINUX)
+ kFlameGraph,
+#endif
+ kDot,
+ kText
+};
+
+static const char* DisplayTypeToString(DisplayType type) {
+ switch (type) {
+#if defined(OS_LINUX)
+ case DisplayType::kFlameGraph: return "flame";
+#endif
+ case DisplayType::kDot: return "dot";
+ case DisplayType::kText: return "text";
+ default: return "unknown";
+ }
+}
+
+static DisplayType StringToDisplayType(const std::string& val) {
+ static butil::CaseIgnoredFlatMap<DisplayType>* display_type_map;
+ static std::once_flag flag;
+ std::call_once(flag, []() {
+ display_type_map = new butil::CaseIgnoredFlatMap<DisplayType>;
+ display_type_map->init(10);
+#if defined(OS_LINUX)
+ (*display_type_map)["flame"] = DisplayType::kFlameGraph;
+#endif
+ (*display_type_map)["dot"] = DisplayType::kDot;
+ (*display_type_map)["text"] = DisplayType::kText;
+ });
+ auto type = display_type_map->seek(val);
+ if (type == nullptr) {
+ return DisplayType::kUnknown;
+ }
+ return *type;
+}
+
+static std::string DisplayTypeToPProfArgument(DisplayType type) {
+ switch (type) {
+#if defined(OS_LINUX)
+ case DisplayType::kFlameGraph: return " --collapsed ";
+ case DisplayType::kDot: return " --dot ";
+ case DisplayType::kText: return " --text ";
+#elif defined(OS_MACOSX)
+ case DisplayType::kDot: return " -dot ";
+ case DisplayType::kText: return " -text ";
+#endif
+ default: return " unknown type ";
+ }
+}
+
+static std::string GeneratePerlScriptPath(const std::string& filename) {
+ std::string path;
+ path.reserve(FLAGS_rpc_profiling_dir.size() + 1 + filename.size());
+ path += FLAGS_rpc_profiling_dir;
+ path.push_back('/');
+ path += filename;
+ return std::move(path);
+}
extern bool cpu_profiler_enabled;
@@ -54,6 +118,7 @@ DEFINE_int32(max_profiles_kept, 32,
BRPC_VALIDATE_GFLAG(max_profiles_kept, PassValidate);
static const char* const PPROF_FILENAME = "pprof.pl";
+static const char* const FLAMEGRAPH_FILENAME = "flamegraph.pl";
static int DEFAULT_PROFILING_SECONDS = 10;
static size_t CONCURRENT_PROFILING_LIMIT = 256;
@@ -228,16 +293,16 @@ static bool ValidProfilePath(const butil::StringPiece& path) {
static int MakeCacheName(char* cache_name, size_t len,
const char* prof_name,
const char* base_name,
- bool use_text,
+ DisplayType display_type,
bool show_ccount) {
if (base_name) {
- return snprintf(cache_name, len, "%s.cache/base_%s%s%s", prof_name,
+ return snprintf(cache_name, len, "%s.cache/base_%s.%s%s", prof_name,
base_name,
- (use_text ? ".text" : ".dot"),
+ DisplayTypeToString(display_type),
(show_ccount ? ".ccount" : ""));
} else {
return snprintf(cache_name, len, "%s.cache/%s%s", prof_name,
- (use_text ? "text" : "dot"),
+ DisplayTypeToString(display_type),
(show_ccount ? ".ccount" : ""));
}
@@ -344,9 +409,16 @@ static void DisplayResult(Controller* cntl,
}
butil::IOBuf& resp = cntl->response_attachment();
const bool use_html = UseHTML(cntl->http_request());
- const bool use_text = cntl->http_request().uri().GetQuery("text");
const bool show_ccount = cntl->http_request().uri().GetQuery("ccount");
const std::string* base_name = cntl->http_request().uri().GetQuery("base");
+ const std::string* display_type_query = cntl->http_request().uri().GetQuery("display_type");
+ DisplayType display_type = DisplayType::kFlameGraph;
+ if (display_type_query) {
+ display_type = StringToDisplayType(*display_type_query);
+ if (display_type == DisplayType::kUnknown) {
+ return cntl->SetFailed(EINVAL, "Invalid display_type=%s", display_type_query->c_str());
+ }
+ }
if (base_name != NULL) {
if (!ValidProfilePath(*base_name)) {
return cntl->SetFailed(EINVAL, "Invalid query `base'");
@@ -361,7 +433,7 @@ static void DisplayResult(Controller* cntl,
char expected_result_name[256];
MakeCacheName(expected_result_name, sizeof(expected_result_name),
prof_name, GetBaseName(base_name),
- use_text, show_ccount);
+ display_type, show_ccount);
// Try to read cache first.
FILE* fp = fopen(expected_result_name, "r");
if (fp != NULL) {
@@ -400,23 +472,29 @@ static void DisplayResult(Controller* cntl,
}
std::ostringstream cmd_builder;
- std::string pprof_tool;
- pprof_tool.reserve(FLAGS_rpc_profiling_dir.size() + 1 + strlen(PPROF_FILENAME));
- pprof_tool += FLAGS_rpc_profiling_dir;
- pprof_tool.push_back('/');
- pprof_tool += PPROF_FILENAME;
-
+
+ std::string pprof_tool{GeneratePerlScriptPath(PPROF_FILENAME)};
+ std::string flamegraph_tool{GeneratePerlScriptPath(FLAMEGRAPH_FILENAME)};
+
#if defined(OS_LINUX)
cmd_builder << "perl " << pprof_tool
- << (use_text ? " --text " : " --dot ")
+ << DisplayTypeToPProfArgument(display_type)
<< (show_ccount ? " --contention " : "");
if (base_name) {
cmd_builder << "--base " << *base_name << ' ';
}
- cmd_builder << GetProgramName() << " " << prof_name << " 2>&1 ";
+
+ cmd_builder << GetProgramName() << " " << prof_name;
+
+ if (display_type == DisplayType::kFlameGraph) {
+ // For flamegraph, we don't care about pprof error msg,
+ // which will cause confusing messages in the final result.
+ cmd_builder << " 2>/dev/null " << " | " << "perl " << flamegraph_tool;
+ }
+ cmd_builder << " 2>&1 ";
#elif defined(OS_MACOSX)
cmd_builder << getenv("GOOGLE_PPROF_BINARY_PATH") << " "
- << (use_text ? " -text " : " -dot ")
+ << DisplayTypeToPProfArgument(display_type)
<< (show_ccount ? " -contentions " : "");
if (base_name) {
cmd_builder << "-base " << *base_name << ' ';
@@ -427,7 +505,8 @@ static void DisplayResult(Controller* cntl,
const std::string cmd = cmd_builder.str();
for (int ntry = 0; ntry < 2; ++ntry) {
if (!g_written_pprof_perl) {
- if (!WriteSmallFile(pprof_tool.c_str(), pprof_perl())) {
+ if (!WriteSmallFile(pprof_tool.c_str(), pprof_perl()) ||
+ !WriteSmallFile(flamegraph_tool.c_str(), flamegraph_perl())) {
os << "Fail to write " << pprof_tool
<< (use_html ? "</body></html>" : "\n");
os.move_to(resp);
@@ -442,12 +521,20 @@ static void DisplayResult(Controller* cntl,
butil::IOBufBuilder pprof_output;
const int rc = butil::read_command_output(pprof_output, cmd.c_str());
if (rc != 0) {
- butil::FilePath path(pprof_tool);
- if (!butil::PathExists(path)) {
+ butil::FilePath pprof_path(pprof_tool);
+ if (!butil::PathExists(pprof_path)) {
// Write the script again.
g_written_pprof_perl = false;
// tell user.
- os << path.value() << " was removed, recreate ...\n\n";
+ os << pprof_path.value() << " was removed, recreate ...\n\n";
+ continue;
+ }
+ butil::FilePath flamegraph_path(flamegraph_tool);
+ if (!butil::PathExists(flamegraph_path)) {
+ // Write the script again.
+ g_written_pprof_perl = false;
+ // tell user.
+ os << flamegraph_path.value() << " was removed, recreate ...\n\n";
continue;
}
if (rc < 0) {
@@ -464,7 +551,7 @@ static void DisplayResult(Controller* cntl,
// Cache result in file.
char result_name[256];
MakeCacheName(result_name, sizeof(result_name), prof_name,
- GetBaseName(base_name), use_text, show_ccount);
+ GetBaseName(base_name), display_type, show_ccount);
// Append the profile name as the visual reminder for what
// current profile is.
@@ -757,7 +844,6 @@ static void StartProfiling(ProfilingType type,
butil::IOBufBuilder os;
bool enabled = false;
const char* extra_desc = "";
-
if (type == PROFILING_CPU) {
enabled = cpu_profiler_enabled;
} else if (type == PROFILING_CONTENTION) {
@@ -796,9 +882,16 @@ static void StartProfiling(ProfilingType type,
const int seconds = ReadSeconds(cntl);
const std::string* view = cntl->http_request().uri().GetQuery("view");
- const bool use_text = cntl->http_request().uri().GetQuery("text");
const bool show_ccount = cntl->http_request().uri().GetQuery("ccount");
const std::string* base_name = cntl->http_request().uri().GetQuery("base");
+ const std::string* display_type_query = cntl->http_request().uri().GetQuery("display_type");
+ DisplayType display_type = DisplayType::kFlameGraph;
+ if (display_type_query) {
+ display_type = StringToDisplayType(*display_type_query);
+ if (display_type == DisplayType::kUnknown) {
+ return cntl->SetFailed(EINVAL, "Invalid display_type=%s", display_type_query->c_str());
+ }
+ }
ProfilingClient profiling_client;
size_t nwaiters = 0;
@@ -824,38 +917,19 @@ static void StartProfiling(ProfilingType type,
"function generateURL() {\n"
" var past_prof = document.getElementById('view_prof').value;\n"
" var base_prof = document.getElementById('base_prof').value;\n"
- " var use_text = document.getElementById('text_cb').checked;\n";
+ " var display_type = document.getElementById('display_type').value;\n";
if (type == PROFILING_CONTENTION) {
os << " var show_ccount = document.getElementById('ccount_cb').checked;\n";
}
os << " var targetURL = '/hotspots/" << type_str << "';\n"
- " var first = true;\n"
+ " targetURL += '?' + 'display_type=' + display_type;\n"
" if (past_prof != '') {\n"
- " if (first) {\n"
- " targetURL += '?';\n"
- " first = false;\n"
- " } else {\n"
- " targetURL += '&';\n"
- " }\n"
+ " targetURL += '&';\n"
" targetURL += 'view=' + past_prof;\n"
" }\n"
" if (base_prof != '') {\n"
- " if (first) {\n"
- " targetURL += '?';\n"
- " first = false;\n"
- " } else {\n"
- " targetURL += '&';\n"
- " }\n"
+ " targetURL += '&';\n"
" targetURL += 'base=' + base_prof;\n"
- " }\n"
- " if (use_text) {\n"
- " if (first) {\n"
- " targetURL += '?';\n"
- " first = false;\n"
- " } else {\n"
- " targetURL += '&';\n"
- " }\n"
- " targetURL += 'text';\n"
" }\n";
if (type == PROFILING_CONTENTION) {
os <<
@@ -904,6 +978,7 @@ static void StartProfiling(ProfilingType type,
" data = data.substring(selEnd + '[addToProfEnd]'.length);\n"
" }\n"
" $(\"#profiling-result\").html('<pre>' + data + '</pre>');\n"
+ " if (data.indexOf('FlameGraph') != -1) { init(); }"
" } else {\n"
" $(\"#profiling-result\").html('Plotting ...');\n"
" var svg = Viz(data.substring(index), \"svg\");\n"
@@ -921,9 +996,7 @@ static void StartProfiling(ProfilingType type,
if (profiling_client.id != 0) {
os << "&profiling_id=" << profiling_client.id;
}
- if (use_text) {
- os << "&text";
- }
+ os << "&display_type=" << DisplayTypeToString(display_type);
if (show_ccount) {
os << "&ccount";
}
@@ -1004,18 +1077,21 @@ static void StartProfiling(ProfilingType type,
}
os << '>' << GetBaseName(&past_profs[i]);
}
- os << "</select>"
- " <label for='text_cb'>"
- "<input id='text_cb' type='checkbox'"
- << (use_text ? " checked=''" : "") <<
- " onclick='onChangedCB(this);'>text</label>";
+ os << "</select>";
+ os << "<div><pre style='display:inline'>Display Type: </pre>"
+ "<select id='display_type' onchange='onSelectProf()'>"
+#if defined(OS_LINUX)
+ "<option value=flame" << (display_type == DisplayType::kFlameGraph ? " selected" : "") << ">flame</option>"
+#endif
+ "<option value=dot" << (display_type == DisplayType::kDot ? " selected" : "") << ">dot</option>"
+ "<option value=text" << (display_type == DisplayType::kText ? " selected" : "") << ">text</option></select>";
if (type == PROFILING_CONTENTION) {
os << " <label for='ccount_cb'>"
"<input id='ccount_cb' type='checkbox'"
<< (show_ccount ? " checked=''" : "") <<
" onclick='onChangedCB(this);'>count</label>";
}
- os << "<br><pre style='display:inline'>Diff: </pre>"
+ os << "</div><div><pre style='display:inline'>Diff: </pre>"
"<select id='base_prof' onchange='onSelectProf()'>"
"<option value=''><none></option>";
for (size_t i = 0; i < past_profs.size(); ++i) {
@@ -1025,7 +1101,7 @@ static void StartProfiling(ProfilingType type,
}
os << '>' << GetBaseName(&past_profs[i]);
}
- os << "</select>";
+ os << "</select></div>";
if (!enabled && view == NULL) {
os << "<p><span style='color:red'>Error:</span> "
@@ -1076,7 +1152,7 @@ static void StartProfiling(ProfilingType type,
}
os << "</div><pre class='logo'><span class='logo_text'>" << logo()
<< "</span></pre></body>\n";
- if (!use_text) {
+ if (display_type == DisplayType::kDot) {
// don't need viz.js in text mode.
os << "<script language=\"javascript\" type=\"text/javascript\""
" src=\"/js/viz_min\"></script>\n";
diff --git a/src/brpc/builtin/pprof_perl.cpp b/src/brpc/builtin/pprof_perl.cpp
index eca74e0..7496cb9 100644
--- a/src/brpc/builtin/pprof_perl.cpp
+++ b/src/brpc/builtin/pprof_perl.cpp
@@ -37,75 +37,118 @@ const char* pprof_perl() {
"use strict;\n"
"use warnings;\n"
"use Getopt::Long;\n"
- "my $PPROF_VERSION = \"1.5\";\n"
+ "use Cwd;\n"
+ "use POSIX;\n"
+ "\n"
+ "my $PPROF_VERSION = \"2.0\";\n"
+ "\n"
+ "# These are the object tools we use which can come from a\n"
+ "# user-specified location using --tools, from the PPROF_TOOLS\n"
+ "# environment variable, or from the environment.\n"
"my %obj_tool_map = (\n"
" \"objdump\" => \"objdump\",\n"
" \"nm\" => \"nm\",\n"
" \"addr2line\" => \"addr2line\",\n"
" \"c++filt\" => \"c++filt\",\n"
- " #\"nm_pdb\" => \"nm-pdb\",\n"
- " #\"addr2line_pdb\" => \"addr2line-pdb\",\n"
- " #\"otool\" => \"otool\",\n"
+ " ## ConfigureObjTools may add architecture-specific entries:\n"
+ " #\"nm_pdb\" => \"nm-pdb\", # for reading windows (PDB-format) executables\n"
+ " #\"addr2line_pdb\" => \"addr2line-pdb\", # ditto\n"
+ " #\"otool\" => \"otool\", # equivalent of objdump on OS X\n"
");\n"
- "my $DOT = \"dot\";\n"
- "if (exists $ENV{\"DOT\"}) {\n"
- " $DOT = $ENV{\"DOT\"}\n"
- "}\n"
- "my $GV = \"gv\";\n"
- "my $KCACHEGRIND = \"kcachegrind\";\n"
- "my $PS2PDF = \"ps2pdf\";\n"
- "my $URL_FETCHER = \"curl -s\";\n"
+ "# NOTE: these are lists, so you can put in commandline flags if you want.\n"
+ "my @DOT = (\"dot\"); # leave non-absolute, since it may be in /usr/local\n"
+ "my @GV = (\"gv\");\n"
+ "my @EVINCE = (\"evince\"); # could also be xpdf or perhaps acroread\n"
+ "my @KCACHEGRIND = (\"kcachegrind\");\n"
+ "my @PS2PDF = (\"ps2pdf\");\n"
+ "# These are used for dynamic profiles\n"
+ "my @URL_FETCHER = (\"curl\", \"-s\");\n"
+ "\n"
+ "# These are the web pages that servers need to support for dynamic profiles\n"
"my $HEAP_PAGE = \"/pprof/heap\";\n"
- "my $PROFILE_PAGE = \"/pprof/profile\";\n"
- "my $PMUPROFILE_PAGE = \"/pprof/pmuprofile(?:\\\\?.*)?\";\n"
+ "my $PROFILE_PAGE = \"/pprof/profile\"; # must support cgi-param \"?seconds=#\"\n"
+ "my $PMUPROFILE_PAGE = \"/pprof/pmuprofile(?:\\\\?.*)?\"; # must support cgi-param\n"
+ " # ?seconds=#&event=x&period=n\n"
"my $GROWTH_PAGE = \"/pprof/growth\";\n"
"my $CONTENTION_PAGE = \"/pprof/contention\";\n"
- "my $WALL_PAGE = \"/pprof/wall(?:\\\\?.*)?\";\n"
+ "my $WALL_PAGE = \"/pprof/wall(?:\\\\?.*)?\"; # accepts options like namefilter\n"
"my $FILTEREDPROFILE_PAGE = \"/pprof/filteredprofile(?:\\\\?.*)?\";\n"
- "my $SYMBOL_PAGE = \"/pprof/symbol\";\n"
+ "my $CENSUSPROFILE_PAGE = \"/pprof/censusprofile(?:\\\\?.*)?\"; # must support "
+ "cgi-param\n"
+ " # \"?seconds=#\",\n"
+ " # \"?tags_regexp=#\" and\n"
+ " # \"?type=#\".\n"
+ "my $SYMBOL_PAGE = \"/pprof/symbol\"; # must support symbol lookup via POST\n"
"my $PROGRAM_NAME_PAGE = \"/pprof/cmdline\";\n"
+ "\n"
+ "# These are the web pages that can be named on the command line.\n"
+ "# All the alternatives must begin with /.\n"
"my $PROFILES = \"($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|\" .\n"
" \"$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|\" .\n"
- " \"$FILTEREDPROFILE_PAGE)\";\n"
+ " \"$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)\";\n"
+ "\n"
+ "# default binary name\n"
"my $UNKNOWN_BINARY = \"(unknown)\";\n"
+ "\n"
+ "# There is a pervasive dependency on the length (in hex characters,\n"
+ "# i.e., nibbles) of an address, distinguishing between 32-bit and\n"
+ "# 64-bit profiles. To err on the safe size, default to 64-bit here:\n"
"my $address_length = 16;\n"
+ "\n"
+ "my $dev_null = \"/dev/null\";\n"
+ "if (! -e $dev_null && $^O =~ /MSWin/) { # $^O is the OS perl was built for\n"
+ " $dev_null = \"nul\";\n"
+ "}\n"
+ "\n"
+ "# A list of paths to search for shared object files\n"
"my @prefix_list = ();\n"
+ "\n"
+ "# Special routine name that should not have any symbols.\n"
+ "# Used as separator to parse \"addr2line -i\" output.\n"
"my $sep_symbol = '_fini';\n"
"my $sep_address = undef;\n"
+ "\n"
+ "my @stackTraces;\n"
+ "\n"
+ "##### Argument parsing #####\n"
+ "\n"
"sub usage_string {\n"
" return <<EOF;\n"
"Usage:\n"
- "pprof [options] <program> <profiles>\n"
+ "$0 [options] <program> <profiles>\n"
" <profiles> is a space separated list of profile names.\n"
- "pprof [options] <symbolized-profiles>\n"
+ "$0 [options] <symbolized-profiles>\n"
" <symbolized-profiles> is a list of profile files where each file contains\n"
" the necessary symbol mappings as well as profile data (likely generated\n"
" with --raw).\n"
- "pprof [options] <profile>\n"
+ "$0 [options] <profile>\n"
" <profile> is a remote form. Symbols are obtained from host:port$SYMBOL_PAGE\n"
" Each name can be:\n"
" /path/to/profile - a path to a profile file\n"
" host:port[/<service>] - a location of a service to get profile from\n"
" The /<service> can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile,\n"
" $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall,\n"
- " or /pprof/filteredprofile.\n"
- " For instance: \"pprof http://myserver.com:80$HEAP_PAGE\".\n"
+ " $CENSUSPROFILE_PAGE, or /pprof/filteredprofile.\n"
+ " For instance:\n"
+ " $0 http://myserver.com:80$HEAP_PAGE\n"
" If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling).\n"
- "pprof --symbols <program>\n"
+ "$0 --symbols <program>\n"
" Maps addresses to symbol names. In this mode, stdin should be a\n"
" list of library mappings, in the same format as is found in the heap-\n"
" and cpu-profile files (this loosely matches that of /proc/self/maps\n"
" on linux), followed by a list of hex addresses to map, one per line.\n"
" For more help with querying remote servers, including how to add the\n"
" necessary server-side support code, see this filename (or one like it):\n"
- " /usr/doc/google-perftools-$PPROF_VERSION/pprof_remote_servers.html\n"
+ " /usr/doc/gperftools-$PPROF_VERSION/pprof_remote_servers.html\n"
"Options:\n"
" --cum Sort by cumulative data\n"
" --base=<base> Subtract <base> from <profile> before display\n"
- " --interactive Run in interactive mode (interactive \"help\" gives help) [default]\n"
+ " --interactive Run in interactive mode (interactive \"help\" gives help) "
+ "[default]\n"
" --seconds=<n> Length of time for dynamic profiles [default=30 secs]\n"
" --add_lib=<file> Read additional symbols and line info from the given library\n"
" --lib_prefix=<dir> Comma separated list of library path prefixes\n"
+ " --no_strip_temp Do not strip template arguments from function names\n"
"Reporting Granularity:\n"
" --addresses Report at address level\n"
" --lines Report at source line level\n"
@@ -113,18 +156,23 @@ const char* pprof_perl() {
" --files Report at source file level\n"
"Output type:\n"
" --text Generate text report\n"
+ " --stacks Generate stack traces similar to the heap profiler (requires "
+ "--text)\n"
" --callgrind Generate callgrind format to stdout\n"
" --gv Generate Postscript and display\n"
+ " --evince Generate PDF and display\n"
" --web Generate SVG and display\n"
" --list=<regexp> Generate source listing of matching routines\n"
" --disasm=<regexp> Generate disassembly of matching routines\n"
" --symbols Print demangled symbol names found at given addresses\n"
" --dot Generate DOT file to stdout\n"
- " --ps Generate Postcript to stdout\n"
+ " --ps Generate Postscript to stdout\n"
" --pdf Generate PDF to stdout\n"
" --svg Generate SVG to stdout\n"
" --gif Generate GIF to stdout\n"
" --raw Generate symbolized pprof data (useful with remote fetch)\n"
+ " --collapsed Generate collapsed stacks for building flame graphs\n"
+ " (see http://www.brendangregg.com/flamegraphs.html)\n"
"Heap-Profile Options:\n"
" --inuse_space Display in-use (mega)bytes [default]\n"
" --inuse_objects Display in-use objects\n"
@@ -140,12 +188,17 @@ const char* pprof_perl() {
" --nodecount=<n> Show at most so many nodes [default=80]\n"
" --nodefraction=<f> Hide nodes below <f>*total [default=.005]\n"
" --edgefraction=<f> Hide edges below <f>*total [default=.001]\n"
+ " --maxdegree=<n> Max incoming/outgoing edges per node [default=8]\n"
" --focus=<regexp> Focus on nodes matching <regexp>\n"
" --ignore=<regexp> Ignore nodes matching <regexp>\n"
" --scale=<n> Set GV scaling [default=0]\n"
" --heapcheck Make nodes with non-0 object counts\n"
" (i.e. direct leak generators) more visible\n"
"Miscellaneous:\n"
+ " --no-auto-signal-frm Automatically drop 2nd frame that is always same (cpu-only)\n"
+ " (assuming that it is artifact of bad stack captures\n"
+ " which include signal handler frames)\n"
+ " --show_addresses Always show addresses when applicable\n"
" --tools=<prefix or binary:fullpath>[,...] \\$PATH for object tool pathnames\n"
" --test Run unit tests\n"
" --help This message\n"
@@ -154,35 +207,36 @@ const char* pprof_perl() {
" PPROF_TMPDIR Profiles directory. Defaults to \\$HOME/pprof\n"
" PPROF_TOOLS Prefix for object tools pathnames\n"
"Examples:\n"
- "pprof /bin/ls ls.prof\n"
+ "$0 /bin/ls ls.prof\n"
" Enters \"interactive\" mode\n"
- "pprof --text /bin/ls ls.prof\n"
+ "$0 --text /bin/ls ls.prof\n"
" Outputs one line per procedure\n"
- "pprof --web /bin/ls ls.prof\n"
+ "$0 --web /bin/ls ls.prof\n"
" Displays annotated call-graph in web browser\n"
- "pprof --gv /bin/ls ls.prof\n"
+ "$0 --gv /bin/ls ls.prof\n"
" Displays annotated call-graph via 'gv'\n"
- "pprof --gv --focus=Mutex /bin/ls ls.prof\n"
+ "$0 --gv --focus=Mutex /bin/ls ls.prof\n"
" Restricts to code paths including a .*Mutex.* entry\n"
- "pprof --gv --focus=Mutex --ignore=string /bin/ls ls.prof\n"
+ "$0 --gv --focus=Mutex --ignore=string /bin/ls ls.prof\n"
" Code paths including Mutex but not string\n"
- "pprof --list=getdir /bin/ls ls.prof\n"
+ "$0 --list=getdir /bin/ls ls.prof\n"
" (Per-line) annotated source listing for getdir()\n"
- "pprof --disasm=getdir /bin/ls ls.prof\n"
+ "$0 --disasm=getdir /bin/ls ls.prof\n"
" (Per-PC) annotated disassembly for getdir()\n"
- "pprof http://localhost:1234/\n"
+ "$0 http://localhost:1234/\n"
" Enters \"interactive\" mode\n"
- "pprof --text localhost:1234\n"
+ "$0 --text localhost:1234\n"
" Outputs one line per procedure for localhost:1234\n"
- "pprof --raw localhost:1234 > ./local.raw\n"
- "pprof --text ./local.raw\n"
+ "$0 --raw localhost:1234 > ./local.raw\n"
+ "$0 --text ./local.raw\n"
" Fetches a remote profile for later analysis and then\n"
" analyzes it in text mode.\n"
"EOF\n"
"}\n"
+ "\n"
"sub version_string {\n"
" return <<EOF\n"
- "pprof (part of google-perftools $PPROF_VERSION)\n"
+ "pprof (part of gperftools $PPROF_VERSION)\n"
"Copyright 1998-2007 Google Inc.\n"
"This is BSD licensed software; see the source for copying conditions\n"
"and license information.\n"
@@ -190,21 +244,31 @@ const char* pprof_perl() {
"PARTICULAR PURPOSE.\n"
"EOF\n"
"}\n"
+ "\n"
"sub usage {\n"
" my $msg = shift;\n"
" print STDERR \"$msg\\n\\n\";\n"
" print STDERR usage_string();\n"
- " print STDERR \"\\nFATAL ERROR: $msg\\n\";\n"
" exit(1);\n"
"}\n"
+ "\n"
"sub Init() {\n"
+ " # Setup tmp-file name and handler to clean it up.\n"
+ " # We do this in the very beginning so that we can use\n"
+ " # error() and cleanup() function anytime here after.\n"
" $main::tmpfile_sym = \"/tmp/pprof$$.sym\";\n"
" $main::tmpfile_ps = \"/tmp/pprof$$\";\n"
" $main::next_tmpfile = 0;\n"
" $SIG{'INT'} = \\&sighandler;\n"
+ "\n"
+ " # Cache from filename/linenumber to source code\n"
" $main::source_cache = ();\n"
+ "\n"
" $main::opt_help = 0;\n"
" $main::opt_version = 0;\n"
+ " $main::opt_show_addresses = 0;\n"
+ " $main::opt_no_auto_signal_frames = 0;\n"
+ "\n"
" $main::opt_cum = 0;\n"
" $main::opt_base = '';\n"
" $main::opt_addresses = 0;\n"
@@ -212,12 +276,15 @@ const char* pprof_perl() {
" $main::opt_functions = 0;\n"
" $main::opt_files = 0;\n"
" $main::opt_lib_prefix = \"\";\n"
+ "\n"
" $main::opt_text = 0;\n"
+ " $main::opt_stacks = 0;\n"
" $main::opt_callgrind = 0;\n"
" $main::opt_list = \"\";\n"
" $main::opt_disasm = \"\";\n"
" $main::opt_symbols = 0;\n"
" $main::opt_gv = 0;\n"
+ " $main::opt_evince = 0;\n"
" $main::opt_web = 0;\n"
" $main::opt_dot = 0;\n"
" $main::opt_ps = 0;\n"
@@ -225,15 +292,19 @@ const char* pprof_perl() {
" $main::opt_gif = 0;\n"
" $main::opt_svg = 0;\n"
" $main::opt_raw = 0;\n"
+ " $main::opt_collapsed = 0;\n"
+ "\n"
" $main::opt_nodecount = 80;\n"
" $main::opt_nodefraction = 0.005;\n"
" $main::opt_edgefraction = 0.001;\n"
+ " $main::opt_maxdegree = 8;\n"
" $main::opt_focus = '';\n"
" $main::opt_ignore = '';\n"
" $main::opt_scale = 0;\n"
" $main::opt_heapcheck = 0;\n"
" $main::opt_seconds = 30;\n"
" $main::opt_lib = \"\";\n"
+ "\n"
" $main::opt_inuse_space = 0;\n"
" $main::opt_inuse_objects = 0;\n"
" $main::opt_alloc_space = 0;\n"
@@ -241,18 +312,39 @@ const char* pprof_perl() {
" $main::opt_show_bytes = 0;\n"
" $main::opt_drop_negative = 0;\n"
" $main::opt_interactive = 0;\n"
+ "\n"
" $main::opt_total_delay = 0;\n"
" $main::opt_contentions = 0;\n"
" $main::opt_mean_delay = 0;\n"
+ "\n"
" $main::opt_tools = \"\";\n"
" $main::opt_debug = 0;\n"
" $main::opt_test = 0;\n"
+ "\n"
+ " # Do not strip template argument in function names\n"
+ " $main::opt_no_strip_temp = 0;\n"
+ "\n"
+ " # These are undocumented flags used only by unittests.\n"
" $main::opt_test_stride = 0;\n"
+ "\n"
+ " # Are we using $SYMBOL_PAGE?\n"
" $main::use_symbol_page = 0;\n"
+ "\n"
+ " # Files returned by TempName.\n"
" %main::tempnames = ();\n"
- " $main::profile_type = '';\n"
+ "\n"
+ " # Type of profile we are dealing with\n"
+ " # Supported types:\n"
+ " # cpu\n"
+ " # heap\n"
+ " # growth\n"
+ " # contention\n"
+ " $main::profile_type = ''; # Empty type means \"unknown\"\n"
+ "\n"
" GetOptions(\"help!\" => \\$main::opt_help,\n"
" \"version!\" => \\$main::opt_version,\n"
+ " \"show_addresses!\"=> \\$main::opt_show_addresses,\n"
+ " \"no-auto-signal-frm!\"=> \\$main::opt_no_auto_signal_frames,\n"
" \"cum!\" => \\$main::opt_cum,\n"
" \"base=s\" => \\$main::opt_base,\n"
" \"seconds=i\" => \\$main::opt_seconds,\n"
@@ -263,11 +355,13 @@ const char* pprof_perl() {
" \"addresses!\" => \\$main::opt_addresses,\n"
" \"files!\" => \\$main::opt_files,\n"
" \"text!\" => \\$main::opt_text,\n"
+ " \"stacks!\" => \\$main::opt_stacks,\n"
" \"callgrind!\" => \\$main::opt_callgrind,\n"
" \"list=s\" => \\$main::opt_list,\n"
" \"disasm=s\" => \\$main::opt_disasm,\n"
" \"symbols!\" => \\$main::opt_symbols,\n"
" \"gv!\" => \\$main::opt_gv,\n"
+ " \"evince!\" => \\$main::opt_evince,\n"
" \"web!\" => \\$main::opt_web,\n"
" \"dot!\" => \\$main::opt_dot,\n"
" \"ps!\" => \\$main::opt_ps,\n"
@@ -275,10 +369,12 @@ const char* pprof_perl() {
" \"svg!\" => \\$main::opt_svg,\n"
" \"gif!\" => \\$main::opt_gif,\n"
" \"raw!\" => \\$main::opt_raw,\n"
+ " \"collapsed!\" => \\$main::opt_collapsed,\n"
" \"interactive!\" => \\$main::opt_interactive,\n"
" \"nodecount=i\" => \\$main::opt_nodecount,\n"
" \"nodefraction=f\" => \\$main::opt_nodefraction,\n"
" \"edgefraction=f\" => \\$main::opt_edgefraction,\n"
+ " \"maxdegree=i\" => \\$main::opt_maxdegree,\n"
" \"focus=s\" => \\$main::opt_focus,\n"
" \"ignore=s\" => \\$main::opt_ignore,\n"
" \"scale=i\" => \\$main::opt_scale,\n"
@@ -293,30 +389,41 @@ const char* pprof_perl() {
" \"contentions!\" => \\$main::opt_contentions,\n"
" \"mean_delay!\" => \\$main::opt_mean_delay,\n"
" \"tools=s\" => \\$main::opt_tools,\n"
+ " \"no_strip_temp!\" => \\$main::opt_no_strip_temp,\n"
" \"test!\" => \\$main::opt_test,\n"
" \"debug!\" => \\$main::opt_debug,\n"
+ " # Undocumented flags used only by unittests:\n"
" \"test_stride=i\" => \\$main::opt_test_stride,\n"
" ) || usage(\"Invalid option(s)\");\n"
+ "\n"
+ " # Deal with the standard --help and --version\n"
" if ($main::opt_help) {\n"
" print usage_string();\n"
" exit(0);\n"
" }\n"
+ "\n"
" if ($main::opt_version) {\n"
" print version_string();\n"
" exit(0);\n"
" }\n"
+ "\n"
+ " # Disassembly/listing/symbols mode requires address-level info\n"
" if ($main::opt_disasm || $main::opt_list || $main::opt_symbols) {\n"
" $main::opt_functions = 0;\n"
" $main::opt_lines = 0;\n"
" $main::opt_addresses = 1;\n"
" $main::opt_files = 0;\n"
" }\n"
+ "\n"
+ " # Check heap-profiling flags\n"
" if ($main::opt_inuse_space +\n"
" $main::opt_inuse_objects +\n"
" $main::opt_alloc_space +\n"
" $main::opt_alloc_objects > 1) {\n"
" usage(\"Specify at most on of --inuse/--alloc options\");\n"
" }\n"
+ "\n"
+ " # Check output granularities\n"
" my $grains =\n"
" $main::opt_functions +\n"
" $main::opt_lines +\n"
@@ -329,6 +436,8 @@ const char* pprof_perl() {
" if ($grains == 0) {\n"
" $main::opt_functions = 1;\n"
" }\n"
+ "\n"
+ " # Check output modes\n"
" my $modes =\n"
" $main::opt_text +\n"
" $main::opt_callgrind +\n"
@@ -336,6 +445,7 @@ const char* pprof_perl() {
" ($main::opt_disasm eq '' ? 0 : 1) +\n"
" ($main::opt_symbols == 0 ? 0 : 1) +\n"
" $main::opt_gv +\n"
+ " $main::opt_evince +\n"
" $main::opt_web +\n"
" $main::opt_dot +\n"
" $main::opt_ps +\n"
@@ -343,43 +453,59 @@ const char* pprof_perl() {
" $main::opt_svg +\n"
" $main::opt_gif +\n"
" $main::opt_raw +\n"
+ " $main::opt_collapsed +\n"
" $main::opt_interactive +\n"
" 0;\n"
" if ($modes > 1) {\n"
" usage(\"Only specify one output mode\");\n"
" }\n"
" if ($modes == 0) {\n"
- " if (-t STDOUT) {\n"
+ " if (-t STDOUT) { # If STDOUT is a tty, activate interactive mode\n"
" $main::opt_interactive = 1;\n"
" } else {\n"
" $main::opt_text = 1;\n"
" }\n"
" }\n"
+ "\n"
" if ($main::opt_test) {\n"
" RunUnitTests();\n"
+ " # Should not return\n"
" exit(1);\n"
" }\n"
+ "\n"
+ " # Binary name and profile arguments list\n"
" $main::prog = \"\";\n"
" @main::pfile_args = ();\n"
- " if (IsProfileURL($ARGV[0])) {\n"
- " $main::use_symbol_page = 1;\n"
- " } elsif (IsSymbolizedProfileFile($ARGV[0])) {\n"
- " $main::use_symbolized_profile = 1;\n"
- " $main::prog = $UNKNOWN_BINARY;\n"
- " }\n"
+ "\n"
+ " # Remote profiling without a binary (using $SYMBOL_PAGE instead)\n"
+ " if (@ARGV > 0) {\n"
+ " if (IsProfileURL($ARGV[0])) {\n"
+ " printf STDERR \"Using remote profile at $ARGV[0].\\n\";\n"
+ " $main::use_symbol_page = 1;\n"
+ " } elsif (IsSymbolizedProfileFile($ARGV[0])) {\n"
+ " $main::use_symbolized_profile = 1;\n"
+ " $main::prog = $UNKNOWN_BINARY; # will be set later from the profile file\n"
+ " }\n"
+ " }\n"
+ "\n"
" if ($main::use_symbol_page || $main::use_symbolized_profile) {\n"
+ " # We don't need a binary!\n"
" my %disabled = ('--lines' => $main::opt_lines,\n"
" '--disasm' => $main::opt_disasm);\n"
" for my $option (keys %disabled) {\n"
" usage(\"$option cannot be used without a binary\") if $disabled{$option};\n"
" }\n"
+ " # Set $main::prog later...\n"
" scalar(@ARGV) || usage(\"Did not specify profile file\");\n"
" } elsif ($main::opt_symbols) {\n"
+ " # --symbols needs a binary-name (to run nm on, etc) but not profiles\n"
" $main::prog = shift(@ARGV) || usage(\"Did not specify program\");\n"
" } else {\n"
" $main::prog = shift(@ARGV) || usage(\"Did not specify program\");\n"
" scalar(@ARGV) || usage(\"Did not specify profile file\");\n"
" }\n"
+ "\n"
+ " # Parse profile file/location arguments\n"
" foreach my $farg (@ARGV) {\n"
" if ($farg =~ m/(.*)\\@([0-9]+)(|\\/.*)$/ ) {\n"
" my $machine = $1;\n"
@@ -392,36 +518,53 @@ const char* pprof_perl() {
" unshift(@main::pfile_args, $farg);\n"
" }\n"
" }\n"
+ "\n"
" if ($main::use_symbol_page) {\n"
" unless (IsProfileURL($main::pfile_args[0])) {\n"
" error(\"The first profile should be a remote form to use $SYMBOL_PAGE\\n\");\n"
" }\n"
" CheckSymbolPage();\n"
" $main::prog = FetchProgramName();\n"
- " } elsif (!$main::use_symbolized_profile) {\n"
+ " } elsif (!$main::use_symbolized_profile) { # may not need objtools!\n"
" ConfigureObjTools($main::prog)\n"
" }\n"
+ "\n"
+ " # Break the opt_lib_prefix into the prefix_list array\n"
" @prefix_list = split (',', $main::opt_lib_prefix);\n"
+ "\n"
+ " # Remove trailing / from the prefixes, in the list to prevent\n"
+ " # searching things like /my/path//lib/mylib.so\n"
" foreach (@prefix_list) {\n"
" s|/+$||;\n"
" }\n"
"}\n"
+ "\n"
"sub Main() {\n"
" Init();\n"
" $main::collected_profile = undef;\n"
" @main::profile_files = ();\n"
" $main::op_time = time();\n"
+ "\n"
+ " # Printing symbols is special and requires a lot less info that most.\n"
" if ($main::opt_symbols) {\n"
- " PrintSymbols(*STDIN);\n"
+ " PrintSymbols(*STDIN); # Get /proc/maps and symbols output from stdin\n"
" return;\n"
" }\n"
+ "\n"
+ " # Fetch all profile data\n"
" FetchDynamicProfiles();\n"
+ "\n"
+ " # this will hold symbols that we read from the profile files\n"
" my $symbol_map = {};\n"
+ "\n"
+ " # Read one profile, pick the last item on the list\n"
" my $data = ReadProfile($main::prog, pop(@main::profile_files));\n"
" my $profile = $data->{profile};\n"
" my $pcs = $data->{pcs};\n"
- " my $libs = $data->{libs};\n"
+ " my $libs = $data->{libs}; # Info about main program and shared libraries\n"
" $symbol_map = MergeSymbols($symbol_map, $data->{symbols});\n"
+ "\n"
+ " # Add additional profiles, if available.\n"
" if (scalar(@main::profile_files) > 0) {\n"
" foreach my $pname (@main::profile_files) {\n"
" my $data2 = ReadProfile($main::prog, $pname);\n"
@@ -430,53 +573,93 @@ const char* pprof_perl() {
" $symbol_map = MergeSymbols($symbol_map, $data2->{symbols});\n"
" }\n"
" }\n"
+ "\n"
+ " # Subtract base from profile, if specified\n"
" if ($main::opt_base ne '') {\n"
" my $base = ReadProfile($main::prog, $main::opt_base);\n"
" $profile = SubtractProfile($profile, $base->{profile});\n"
" $pcs = AddPcs($pcs, $base->{pcs});\n"
" $symbol_map = MergeSymbols($symbol_map, $base->{symbols});\n"
" }\n"
+ "\n"
+ " # Get total data in profile\n"
" my $total = TotalProfile($profile);\n"
+ "\n"
+ " # Collect symbols\n"
" my $symbols;\n"
" if ($main::use_symbolized_profile) {\n"
" $symbols = FetchSymbols($pcs, $symbol_map);\n"
" } elsif ($main::use_symbol_page) {\n"
" $symbols = FetchSymbols($pcs);\n"
" } else {\n"
+ " # TODO(csilvers): $libs uses the /proc/self/maps data from profile1,\n"
+ " # which may differ from the data from subsequent profiles, especially\n"
+ " # if they were run on different machines. Use appropriate libs for\n"
+ " # each pc somehow.\n"
" $symbols = ExtractSymbols($libs, $pcs);\n"
" }\n"
+ "\n"
+ " # Remove uniniteresting stack items\n"
" $profile = RemoveUninterestingFrames($symbols, $profile);\n"
+ "\n"
+ " # Focus?\n"
" if ($main::opt_focus ne '') {\n"
" $profile = FocusProfile($symbols, $profile, $main::opt_focus);\n"
" }\n"
+ "\n"
+ " # Ignore?\n"
" if ($main::opt_ignore ne '') {\n"
" $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore);\n"
" }\n"
+ "\n"
" my $calls = ExtractCalls($symbols, $profile);\n"
+ "\n"
+ " # Reduce profiles to required output granularity, and also clean\n"
+ " # each stack trace so a given entry exists at most once.\n"
" my $reduced = ReduceProfile($symbols, $profile);\n"
+ "\n"
+ " # Get derived profiles\n"
" my $flat = FlatProfile($reduced);\n"
" my $cumulative = CumulativeProfile($reduced);\n"
+ "\n"
+ " # Print\n"
" if (!$main::opt_interactive) {\n"
" if ($main::opt_disasm) {\n"
- " PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm, $total);\n"
+ " PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm);\n"
" } elsif ($main::opt_list) {\n"
- " PrintListing($libs, $flat, $cumulative, $main::opt_list);\n"
+ " PrintListing($total, $libs, $flat, $cumulative, $main::opt_list, 0);\n"
" } elsif ($main::opt_text) {\n"
+ " # Make sure the output is empty when have nothing to report\n"
+ " # (only matters when --heapcheck is given but we must be\n"
+ " # compatible with old branches that did not pass --heapcheck always):\n"
" if ($total != 0) {\n"
" printf(\"Total: %s %s\\n\", Unparse($total), Units());\n"
" }\n"
- " PrintText($symbols, $flat, $cumulative, $total, -1);\n"
+ " if ($main::opt_stacks) {\n"
+ " printf(\"Stacks:\\n\\n\");\n"
+ " PrintStacksForText($symbols, $profile);\n"
+ " }\n"
+ " PrintText($symbols, $flat, $cumulative, -1);\n"
" } elsif ($main::opt_raw) {\n"
" PrintSymbolizedProfile($symbols, $profile, $main::prog);\n"
+ " } elsif ($main::opt_collapsed) {\n"
+ " PrintCollapsedStacks($symbols, $profile);\n"
" } elsif ($main::opt_callgrind) {\n"
" PrintCallgrind($calls);\n"
" } else {\n"
" if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {\n"
" if ($main::opt_gv) {\n"
" RunGV(TempName($main::next_tmpfile, \"ps\"), \"\");\n"
+ " } elsif ($main::opt_evince) {\n"
+ " RunEvince(TempName($main::next_tmpfile, \"pdf\"), \"\");\n"
" } elsif ($main::opt_web) {\n"
" my $tmp = TempName($main::next_tmpfile, \"svg\");\n"
" RunWeb($tmp);\n"
+ " # The command we run might hand the file name off\n"
+ " # to an already running browser instance and then exit.\n"
+ " # Normally, we'd remove $tmp on exit (right now),\n"
+ " # but fork a child to remove $tmp a little later, so that the\n"
+ " # browser has time to load it first.\n"
" delete $main::tempnames{$tmp};\n"
" if (fork() == 0) {\n"
" sleep 5;\n"
@@ -492,34 +675,71 @@ const char* pprof_perl() {
" } else {\n"
" InteractiveMode($profile, $symbols, $libs, $total);\n"
" }\n"
+ "\n"
" cleanup();\n"
" exit(0);\n"
"}\n"
+ "\n"
+ "##### Entry Point #####\n"
+ "\n"
"Main();\n"
+ "\n"
+ "# Temporary code to detect if we're running on a Goobuntu system.\n"
+ "# These systems don't have the right stuff installed for the special\n"
+ "# Readline libraries to work, so as a temporary workaround, we default\n"
+ "# to using the normal stdio code, rather than the fancier readline-based\n"
+ "# code\n"
"sub ReadlineMightFail {\n"
" if (-e '/lib/libtermcap.so.2') {\n"
- " return 0;\n"
+ " return 0; # libtermcap exists, so readline should be okay\n"
" } else {\n"
" return 1;\n"
" }\n"
"}\n"
+ "\n"
"sub RunGV {\n"
" my $fname = shift;\n"
- " my $bg = shift;\n"
- " if (!system(\"$GV --version >/dev/null 2>&1\")) {\n"
- " system(\"$GV --scale=$main::opt_scale --noantialias \" . $fname . $bg);\n"
+ " my $bg = shift; # \"\" or \" &\" if we should run in background\n"
+ " if (!system(ShellEscape(@GV, \"--version\") . \" >$dev_null 2>&1\")) {\n"
+ " # Options using double dash are supported by this gv version.\n"
+ " # Also, turn on noantialias to better handle bug in gv for\n"
+ " # postscript files with large dimensions.\n"
+ " # TODO: Maybe we should not pass the --noantialias flag\n"
+ " # if the gv version is known to work properly without the flag.\n"
+ " system(ShellEscape(@GV, \"--scale=$main::opt_scale\", \"--noantialias\", $fname)\n"
+ " . $bg);\n"
" } else {\n"
- " print STDERR \"$GV -scale $main::opt_scale\\n\";\n"
- " system(\"$GV -scale $main::opt_scale \" . $fname . $bg);\n"
+ " # Old gv version - only supports options that use single dash.\n"
+ " print STDERR ShellEscape(@GV, \"-scale\", $main::opt_scale) . \"\\n\";\n"
+ " system(ShellEscape(@GV, \"-scale\", \"$main::opt_scale\", $fname) . $bg);\n"
" }\n"
"}\n"
+ "\n"
+ "sub RunEvince {\n"
+ " my $fname = shift;\n"
+ " my $bg = shift; # \"\" or \" &\" if we should run in background\n"
+ " system(ShellEscape(@EVINCE, $fname) . $bg);\n"
+ "}\n"
+ "\n"
"sub RunWeb {\n"
" my $fname = shift;\n"
" print STDERR \"Loading web page file:///$fname\\n\";\n"
+ "\n"
" if (`uname` =~ /Darwin/) {\n"
+ " # OS X: open will use standard preference for SVG files.\n"
" system(\"/usr/bin/open\", $fname);\n"
" return;\n"
" }\n"
+ "\n"
+ " if (`uname` =~ /MINGW/) {\n"
+ " # Windows(MinGW): open will use standard preference for SVG files.\n"
+ " system(\"cmd\", \"/c\", \"start\", $fname);\n"
+ " return;\n"
+ " }\n"
+ "\n"
+ " # Some kind of Unix; try generic symlinks, then specific browsers.\n"
+ " # (Stop once we find one.)\n"
+ " # Works best if the browser is already running.\n"
" my @alt = (\n"
" \"/etc/alternatives/gnome-www-browser\",\n"
" \"/etc/alternatives/x-www-browser\",\n"
@@ -531,18 +751,27 @@ const char* pprof_perl() {
" return;\n"
" }\n"
" }\n"
+ "\n"
" print STDERR \"Could not load web browser.\\n\";\n"
"}\n"
+ "\n"
"sub RunKcachegrind {\n"
" my $fname = shift;\n"
- " my $bg = shift;\n"
- " print STDERR \"Starting '$KCACHEGRIND \" . $fname . $bg . \"'\\n\";\n"
- " system(\"$KCACHEGRIND \" . $fname . $bg);\n"
+ " my $bg = shift; # \"\" or \" &\" if we should run in background\n"
+ " print STDERR \"Starting '@KCACHEGRIND \" . $fname . $bg . \"'\\n\";\n"
+ " system(ShellEscape(@KCACHEGRIND, $fname) . $bg);\n"
"}\n"
+ "\n"
+ "\n"
+ "##### Interactive helper routines #####\n"
+ "\n"
"sub InteractiveMode {\n"
- " $| = 1;\n"
+ " $| = 1; # Make output unbuffered for interactive mode\n"
" my ($orig_profile, $symbols, $libs, $total) = @_;\n"
+ "\n"
" print STDERR \"Welcome to pprof! For help, type 'help'.\\n\";\n"
+ "\n"
+ " # Use ReadLine if it's installed and input comes from a console.\n"
" if ( -t STDIN &&\n"
" !ReadlineMightFail() &&\n"
" defined(eval {require Term::ReadLine}) ) {\n"
@@ -550,26 +779,34 @@ const char* pprof_perl() {
" while ( defined ($_ = $term->readline('(pprof) '))) {\n"
" $term->addhistory($_) if /\\S/;\n"
" if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {\n"
- " last;\n"
+ " last; # exit when we get an interactive command to quit\n"
" }\n"
" }\n"
- " } else {\n"
+ " } else { # don't have readline\n"
" while (1) {\n"
" print STDERR \"(pprof) \";\n"
" $_ = <STDIN>;\n"
" last if ! defined $_ ;\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
+ "\n"
+ " # Save some flags that might be reset by InteractiveCommand()\n"
" my $save_opt_lines = $main::opt_lines;\n"
+ "\n"
" if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {\n"
- " last;\n"
+ " last; # exit when we get an interactive command to quit\n"
" }\n"
+ "\n"
+ " # Restore flags\n"
" $main::opt_lines = $save_opt_lines;\n"
" }\n"
" }\n"
"}\n"
+ "\n"
+ "# Takes two args: orig profile, and command to run.\n"
+ "# Returns 1 if we should keep going, or 0 if we were asked to quit\n"
"sub InteractiveCommand {\n"
" my($orig_profile, $symbols, $libs, $total, $command) = @_;\n"
- " $_ = $command;\n"
+ " $_ = $command; # just to make future m//'s easier\n"
" if (!defined($_)) {\n"
" print STDERR \"\\n\";\n"
" return 0;\n"
@@ -581,27 +818,38 @@ const char* pprof_perl() {
" InteractiveHelpMessage();\n"
" return 1;\n"
" }\n"
+ " # Clear all the mode options -- mode is controlled by \"$command\"\n"
" $main::opt_text = 0;\n"
" $main::opt_callgrind = 0;\n"
" $main::opt_disasm = 0;\n"
" $main::opt_list = 0;\n"
" $main::opt_gv = 0;\n"
+ " $main::opt_evince = 0;\n"
" $main::opt_cum = 0;\n"
+ "\n"
" if (m/^\\s*(text|top)(\\d*)\\s*(.*)/) {\n"
" $main::opt_text = 1;\n"
+ "\n"
" my $line_limit = ($2 ne \"\") ? int($2) : 10;\n"
+ "\n"
" my $routine;\n"
" my $ignore;\n"
" ($routine, $ignore) = ParseInteractiveArgs($3);\n"
- " my $profile = ProcessProfile($orig_profile, $symbols, \"\", $ignore);\n"
+ "\n"
+ " my $profile = ProcessProfile($total, $orig_profile, $symbols, \"\", $ignore);\n"
" my $reduced = ReduceProfile($symbols, $profile);\n"
+ "\n"
+ " # Get derived profiles\n"
" my $flat = FlatProfile($reduced);\n"
" my $cumulative = CumulativeProfile($reduced);\n"
- " PrintText($symbols, $flat, $cumulative, $total, $line_limit);\n"
+ "\n"
+ " PrintText($symbols, $flat, $cumulative, $line_limit);\n"
" return 1;\n"
" }\n"
" if (m/^\\s*callgrind\\s*([^ \\n]*)/) {\n"
" $main::opt_callgrind = 1;\n"
+ "\n"
+ " # Get derived profiles\n"
" my $calls = ExtractCalls($symbols, $orig_profile);\n"
" my $filename = $1;\n"
" if ( $1 eq '' ) {\n"
@@ -612,50 +860,75 @@ const char* pprof_perl() {
" RunKcachegrind($filename, \" & \");\n"
" $main::next_tmpfile++;\n"
" }\n"
+ "\n"
" return 1;\n"
" }\n"
- " if (m/^\\s*list\\s*(.+)/) {\n"
+ " if (m/^\\s*(web)?list\\s*(.+)/) {\n"
+ " my $html = (defined($1) && ($1 eq \"web\"));\n"
" $main::opt_list = 1;\n"
+ "\n"
" my $routine;\n"
" my $ignore;\n"
- " ($routine, $ignore) = ParseInteractiveArgs($1);\n"
- " my $profile = ProcessProfile($orig_profile, $symbols, \"\", $ignore);\n"
+ " ($routine, $ignore) = ParseInteractiveArgs($2);\n"
+ "\n"
+ " my $profile = ProcessProfile($total, $orig_profile, $symbols, \"\", $ignore);\n"
" my $reduced = ReduceProfile($symbols, $profile);\n"
+ "\n"
+ " # Get derived profiles\n"
" my $flat = FlatProfile($reduced);\n"
" my $cumulative = CumulativeProfile($reduced);\n"
- " PrintListing($libs, $flat, $cumulative, $routine);\n"
+ "\n"
+ " PrintListing($total, $libs, $flat, $cumulative, $routine, $html);\n"
" return 1;\n"
" }\n"
" if (m/^\\s*disasm\\s*(.+)/) {\n"
" $main::opt_disasm = 1;\n"
+ "\n"
" my $routine;\n"
" my $ignore;\n"
" ($routine, $ignore) = ParseInteractiveArgs($1);\n"
- " my $profile = ProcessProfile($orig_profile, $symbols, \"\", $ignore);\n"
+ "\n"
+ " # Process current profile to account for various settings\n"
+ " my $profile = ProcessProfile($total, $orig_profile, $symbols, \"\", $ignore);\n"
" my $reduced = ReduceProfile($symbols, $profile);\n"
+ "\n"
+ " # Get derived profiles\n"
" my $flat = FlatProfile($reduced);\n"
" my $cumulative = CumulativeProfile($reduced);\n"
- " PrintDisassembly($libs, $flat, $cumulative, $routine, $total);\n"
+ "\n"
+ " PrintDisassembly($libs, $flat, $cumulative, $routine);\n"
" return 1;\n"
" }\n"
- " if (m/^\\s*(gv|web)\\s*(.*)/) {\n"
+ " if (m/^\\s*(gv|web|evince)\\s*(.*)/) {\n"
" $main::opt_gv = 0;\n"
+ " $main::opt_evince = 0;\n"
" $main::opt_web = 0;\n"
" if ($1 eq \"gv\") {\n"
" $main::opt_gv = 1;\n"
+ " } elsif ($1 eq \"evince\") {\n"
+ " $main::opt_evince = 1;\n"
" } elsif ($1 eq \"web\") {\n"
" $main::opt_web = 1;\n"
" }\n"
+ "\n"
" my $focus;\n"
" my $ignore;\n"
" ($focus, $ignore) = ParseInteractiveArgs($2);\n"
- " my $profile = ProcessProfile($orig_profile, $symbols, $focus, $ignore);\n"
+ "\n"
+ " # Process current profile to account for various settings\n"
+ " my $profile = ProcessProfile($total, $orig_profile, $symbols,\n"
+ " $focus, $ignore);\n"
" my $reduced = ReduceProfile($symbols, $profile);\n"
+ "\n"
+ " # Get derived profiles\n"
" my $flat = FlatProfile($reduced);\n"
" my $cumulative = CumulativeProfile($reduced);\n"
+ "\n"
" if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {\n"
" if ($main::opt_gv) {\n"
" RunGV(TempName($main::next_tmpfile, \"ps\"), \" &\");\n"
+ " } elsif ($main::opt_evince) {\n"
+ " RunEvince(TempName($main::next_tmpfile, \"pdf\"), \" &\");\n"
" } elsif ($main::opt_web) {\n"
" RunWeb(TempName($main::next_tmpfile, \"svg\"));\n"
" }\n"
@@ -669,13 +942,17 @@ const char* pprof_perl() {
" print STDERR \"Unknown command: try 'help'.\\n\";\n"
" return 1;\n"
"}\n"
+ "\n"
+ "\n"
"sub ProcessProfile {\n"
+ " my $total_count = shift;\n"
" my $orig_profile = shift;\n"
" my $symbols = shift;\n"
" my $focus = shift;\n"
" my $ignore = shift;\n"
+ "\n"
+ " # Process current profile to account for various settings\n"
" my $profile = $orig_profile;\n"
- " my $total_count = TotalProfile($profile);\n"
" printf(\"Total: %s %s\\n\", Unparse($total_count), Units());\n"
" if ($focus ne '') {\n"
" $profile = FocusProfile($symbols, $profile, $focus);\n"
@@ -694,8 +971,10 @@ const char* pprof_perl() {
" Unparse($total_count),\n"
" ($ignore_count*100.0) / $total_count);\n"
" }\n"
+ "\n"
" return $profile;\n"
"}\n"
+ "\n"
"sub InteractiveHelpMessage {\n"
" print STDERR <<ENDOFHELP;\n"
"Interactive pprof mode\n"
@@ -716,6 +995,10 @@ const char* pprof_perl() {
" On OS X, change the Finder association for SVG files.\n"
" list [routine_regexp] [-ignore1] [-ignore2]\n"
" Show source listing of routines whose names match \"routine_regexp\"\n"
+ " weblist [routine_regexp] [-ignore1] [-ignore2]\n"
+ " Displays a source listing of routines whose names match \"routine_regexp\"\n"
+ " in a web browser. You can click on source lines to view the\n"
+ " corresponding disassembly.\n"
" top [--cum] [-ignore1] [-ignore2]\n"
" top20 [--cum] [-ignore1] [-ignore2]\n"
" top37 [--cum] [-ignore1] [-ignore2]\n"
@@ -734,8 +1017,8 @@ const char* pprof_perl() {
"the stack trace matches the regular expression in any of the -ignore\n"
"parameters will be ignored.\n"
"Further pprof details are available at this location (or one similar):\n"
- " /usr/doc/google-perftools-$PPROF_VERSION/cpu_profiler.html\n"
- " /usr/doc/google-perftools-$PPROF_VERSION/heap_profiler.html\n"
+ " /usr/doc/gperftools-$PPROF_VERSION/cpu_profiler.html\n"
+ " /usr/doc/gperftools-$PPROF_VERSION/heap_profiler.html\n"
"ENDOFHELP\n"
"}\n"
"sub ParseInteractiveArgs {\n"
@@ -759,6 +1042,9 @@ const char* pprof_perl() {
" }\n"
" return ($focus, $ignore);\n"
"}\n"
+ "\n"
+ "##### Output code #####\n"
+ "\n"
"sub TempName {\n"
" my $fnum = shift;\n"
" my $ext = shift;\n"
@@ -766,36 +1052,65 @@ const char* pprof_perl() {
" $main::tempnames{$file} = 1;\n"
" return $file;\n"
"}\n"
+ "\n"
+ "# Print profile data in packed binary format (64-bit) to standard out\n"
"sub PrintProfileData {\n"
" my $profile = shift;\n"
- " print pack('L*', 0, 0, 3, 0, 0, 0, 1, 0, 0, 0);\n"
+ " my $big_endian = pack(\"L\", 1) eq pack(\"N\", 1);\n"
+ " # print header (64-bit style)\n"
+ " # (zero) (header-size) (version) (sample-period) (zero)\n"
+ " if ($big_endian) {\n"
+ " print pack('L*', 0, 0, 0, 3, 0, 0, 0, 1, 0, 0);\n"
+ " }\n"
+ " else {\n"
+ " print pack('L*', 0, 0, 3, 0, 0, 0, 1, 0, 0, 0);\n"
+ " }\n"
+ "\n"
" foreach my $k (keys(%{$profile})) {\n"
" my $count = $profile->{$k};\n"
" my @addrs = split(/\\n/, $k);\n"
" if ($#addrs >= 0) {\n"
" my $depth = $#addrs + 1;\n"
- " print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32));\n"
- " print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32));\n"
+ " # int(foo / 2**32) is the only reliable way to get rid of bottom\n"
+ " # 32 bits on both 32- and 64-bit systems.\n"
+ " if ($big_endian) {\n"
+ " print pack('L*', int($count / 2**32), $count & 0xFFFFFFFF);\n"
+ " print pack('L*', int($depth / 2**32), $depth & 0xFFFFFFFF);\n"
+ " }\n"
+ " else {\n"
+ " print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32));\n"
+ " print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32));\n"
+ " }\n"
+ "\n"
" foreach my $full_addr (@addrs) {\n"
" my $addr = $full_addr;\n"
- " $addr =~ s/0x0*//;\n"
+ " $addr =~ s/0x0*//; # strip off leading 0x, zeroes\n"
" if (length($addr) > 16) {\n"
" print STDERR \"Invalid address in profile: $full_addr\\n\";\n"
" next;\n"
" }\n"
- " my $low_addr = substr($addr, -8);\n"
- " my $high_addr = substr($addr, -16, 8);\n"
- " print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr));\n"
+ " my $low_addr = substr($addr, -8); # get last 8 hex chars\n"
+ " my $high_addr = substr($addr, -16, 8); # get up to 8 more hex chars\n"
+ " if ($big_endian) {\n"
+ " print pack('L*', hex('0x' . $high_addr), hex('0x' . $low_addr));\n"
+ " }\n"
+ " else {\n"
+ " print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr));\n"
+ " }\n"
" }\n"
" }\n"
" }\n"
"}\n"
+ "\n"
+ "# Print symbols and profile data\n"
"sub PrintSymbolizedProfile {\n"
" my $symbols = shift;\n"
" my $profile = shift;\n"
" my $prog = shift;\n"
- " $SYMBOL_PAGE =~ m,[^/]+$,;\n"
+ "\n"
+ " $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash\n"
" my $symbol_marker = $&;\n"
+ "\n"
" print '--- ', $symbol_marker, \"\\n\";\n"
" if (defined($prog)) {\n"
" print 'binary=', $prog, \"\\n\";\n"
@@ -803,6 +1118,9 @@ const char* pprof_perl() {
" while (my ($pc, $name) = each(%{$symbols})) {\n"
" my $sep = ' ';\n"
" print '0x', $pc;\n"
+ " # We have a list of function names, which include the inlined\n"
+ " # calls. They are separated (and terminated) by --, which is\n"
+ " # illegal in function names.\n"
" for (my $j = 2; $j <= $#{$name}; $j += 3) {\n"
" print $sep, $name->[$j];\n"
" $sep = '--';\n"
@@ -810,26 +1128,55 @@ const char* pprof_perl() {
" print \"\\n\";\n"
" }\n"
" print '---', \"\\n\";\n"
- " $PROFILE_PAGE =~ m,[^/]+$,;\n"
+ "\n"
+ " $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash\n"
" my $profile_marker = $&;\n"
" print '--- ', $profile_marker, \"\\n\";\n"
" if (defined($main::collected_profile)) {\n"
+ " # if used with remote fetch, simply dump the collected profile to output.\n"
" open(SRC, \"<$main::collected_profile\");\n"
" while (<SRC>) {\n"
" print $_;\n"
" }\n"
" close(SRC);\n"
" } else {\n"
+ " # dump a cpu-format profile to standard out\n"
" PrintProfileData($profile);\n"
" }\n"
"}\n"
+ "\n"
+ "# Print text output\n"
"sub PrintText {\n"
" my $symbols = shift;\n"
" my $flat = shift;\n"
" my $cumulative = shift;\n"
- " my $total = shift;\n"
" my $line_limit = shift;\n"
+ "\n"
+ " if ($main::opt_stacks && @stackTraces) {\n"
+ " foreach (sort { (split \" \", $b)[1] <=> (split \" \", $a)[1]; } @stackTraces) "
+ "{\n"
+ " print \"$_\\n\" if $main::opt_debug;\n"
+ " my ($n1, $s1, $n2, $s2, @addrs) = split;\n"
+ " print \"Leak of $s1 bytes in $n1 objects allocated from:\\n\";\n"
+ " foreach my $pcstr (@addrs) {\n"
+ " $pcstr =~ s/^0x//;\n"
+ " my $sym;\n"
+ " if (! defined $symbols->{$pcstr}) {\n"
+ " $sym = \"unknown\";\n"
+ " } else {\n"
+ " $sym = \"$symbols->{$pcstr}[0] $symbols->{$pcstr}[1]\";\n"
+ " }\n"
+ " print \"\\t@ $pcstr $sym\\n\";\n"
+ " }\n"
+ " }\n"
+ " print \"\\n\";\n"
+ " }\n"
+ "\n"
+ " my $total = TotalProfile($flat);\n"
+ "\n"
+ " # Which profile to sort by?\n"
" my $s = $main::opt_cum ? $cumulative : $flat;\n"
+ "\n"
" my $running_sum = 0;\n"
" my $lines = 0;\n"
" foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b }\n"
@@ -837,6 +1184,7 @@ const char* pprof_perl() {
" my $f = GetEntry($flat, $k);\n"
" my $c = GetEntry($cumulative, $k);\n"
" $running_sum += $f;\n"
+ "\n"
" my $sym = $k;\n"
" if (exists($symbols->{$k})) {\n"
" $sym = $symbols->{$k}->[0] . \" \" . $symbols->{$k}->[1];\n"
@@ -844,6 +1192,7 @@ const char* pprof_perl() {
" $sym = $k . \" \" . $sym;\n"
" }\n"
" }\n"
+ "\n"
" if ($f != 0 || $c != 0) {\n"
" printf(\"%8s %6s %6s %8s %6s %s\\n\",\n"
" Unparse($f),\n"
@@ -854,20 +1203,47 @@ const char* pprof_perl() {
" $sym);\n"
" }\n"
" $lines++;\n"
- " last if ($line_limit >= 0 && $lines > $line_limit);\n"
+ " last if ($line_limit >= 0 && $lines >= $line_limit);\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "# Callgrind format has a compression for repeated function and file\n"
+ "# names. You show the name the first time, and just use its number\n"
+ "# subsequently. This can cut down the file to about a third or a\n"
+ "# quarter of its uncompressed size. $key and $val are the key/value\n"
+ "# pair that would normally be printed by callgrind; $map is a map from\n"
+ "# value to number.\n"
+ "sub CompressedCGName {\n"
+ " my($key, $val, $map) = @_;\n"
+ " my $idx = $map->{$val};\n"
+ " # For very short keys, providing an index hurts rather than helps.\n"
+ " if (length($val) <= 3) {\n"
+ " return \"$key=$val\\n\";\n"
+ " } elsif (defined($idx)) {\n"
+ " return \"$key=($idx)\\n\";\n"
+ " } else {\n"
+ " # scalar(keys $map) gives the number of items in the map.\n"
+ " $idx = scalar(keys(%{$map})) + 1;\n"
+ " $map->{$val} = $idx;\n"
+ " return \"$key=($idx) $val\\n\";\n"
" }\n"
"}\n"
+ "\n"
+ "# Print the call graph in a way that's suiteable for callgrind.\n"
"sub PrintCallgrind {\n"
" my $calls = shift;\n"
" my $filename;\n"
+ " my %filename_to_index_map;\n"
+ " my %fnname_to_index_map;\n"
+ "\n"
" if ($main::opt_interactive) {\n"
" $filename = shift;\n"
" print STDERR \"Writing callgrind file to '$filename'.\\n\"\n"
" } else {\n"
" $filename = \"&STDOUT\";\n"
" }\n"
- " open(CG, \">\".$filename );\n"
- " printf CG (\"events: Hits\\n\\n\");\n"
+ " open(CG, \">$filename\");\n"
+ " print CG (\"events: Hits\\n\\n\");\n"
" foreach my $call ( map { $_->[0] }\n"
" sort { $a->[1] cmp $b ->[1] ||\n"
" $a->[2] <=> $b->[2] }\n"
@@ -879,27 +1255,37 @@ const char* pprof_perl() {
" my ( $caller_file, $caller_line, $caller_function,\n"
" $callee_file, $callee_line, $callee_function ) =\n"
" ( $1, $2, $3, $5, $6, $7 );\n"
- " printf CG (\"fl=$caller_file\\nfn=$caller_function\\n\");\n"
+ "\n"
+ " # TODO(csilvers): for better compression, collect all the\n"
+ " # caller/callee_files and functions first, before printing\n"
+ " # anything, and only compress those referenced more than once.\n"
+ " print CG CompressedCGName(\"fl\", $caller_file, \\%filename_to_index_map);\n"
+ " print CG CompressedCGName(\"fn\", $caller_function, \\%fnname_to_index_map);\n"
" if (defined $6) {\n"
- " printf CG (\"cfl=$callee_file\\n\");\n"
- " printf CG (\"cfn=$callee_function\\n\");\n"
- " printf CG (\"calls=$count $callee_line\\n\");\n"
+ " print CG CompressedCGName(\"cfl\", $callee_file, \\%filename_to_index_map);\n"
+ " print CG CompressedCGName(\"cfn\", $callee_function, \\%fnname_to_index_map);\n"
+ " print CG (\"calls=$count $callee_line\\n\");\n"
" }\n"
- " printf CG (\"$caller_line $count\\n\\n\");\n"
+ " print CG (\"$caller_line $count\\n\\n\");\n"
" }\n"
"}\n"
+ "\n"
+ "# Print disassembly for all all routines that match $main::opt_disasm\n"
"sub PrintDisassembly {\n"
" my $libs = shift;\n"
" my $flat = shift;\n"
" my $cumulative = shift;\n"
" my $disasm_opts = shift;\n"
- " my $total = shift;\n"
+ "\n"
+ " my $total = TotalProfile($flat);\n"
+ "\n"
" foreach my $lib (@{$libs}) {\n"
" my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts);\n"
" my $offset = AddressSub($lib->[1], $lib->[3]);\n"
" foreach my $routine (sort ByName keys(%{$symbol_table})) {\n"
" my $start_addr = $symbol_table->{$routine}->[0];\n"
" my $end_addr = $symbol_table->{$routine}->[1];\n"
+ " # See if there are any samples in this routine\n"
" my $length = hex(AddressSub($end_addr, $start_addr));\n"
" my $addr = AddressAdd($start_addr, $offset);\n"
" for (my $i = 0; $i < $length; $i++) {\n"
@@ -914,30 +1300,39 @@ const char* pprof_perl() {
" }\n"
" }\n"
"}\n"
+ "\n"
+ "# Return reference to array of tuples of the form:\n"
+ "# [start_address, filename, linenumber, instruction, limit_address]\n"
+ "# E.g.,\n"
+ "# [\"0x806c43d\", \"/foo/bar.cc\", 131, \"ret\", \"0x806c440\"]\n"
"sub Disassemble {\n"
" my $prog = shift;\n"
" my $offset = shift;\n"
" my $start_addr = shift;\n"
" my $end_addr = shift;\n"
+ "\n"
" my $objdump = $obj_tool_map{\"objdump\"};\n"
- " my $cmd = sprintf(\"$objdump -C -d -l --no-show-raw-insn \" .\n"
- " \"--start-address=0x$start_addr \" .\n"
- " \"--stop-address=0x$end_addr $prog\");\n"
- " open(OBJDUMP, \"$cmd |\") || error(\"$objdump: $!\\n\");\n"
+ " my $cmd = ShellEscape($objdump, \"-C\", \"-d\", \"-l\", \"--no-show-raw-insn\",\n"
+ " \"--start-address=0x$start_addr\",\n"
+ " \"--stop-address=0x$end_addr\", $prog);\n"
+ " open(OBJDUMP, \"$cmd |\") || error(\"$cmd: $!\\n\");\n"
" my @result = ();\n"
" my $filename = \"\";\n"
" my $linenumber = -1;\n"
" my $last = [\"\", \"\", \"\", \"\"];\n"
" while (<OBJDUMP>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" chop;\n"
" if (m|\\s*([^:\\s]+):(\\d+)\\s*$|) {\n"
+ " # Location line of the form:\n"
+ " # <filename>:<linenumber>\n"
" $filename = $1;\n"
" $linenumber = $2;\n"
" } elsif (m/^ +([0-9a-f]+):\\s*(.*)/) {\n"
+ " # Disassembly line -- zero-extend address to full length\n"
" my $addr = HexExtend($1);\n"
" my $k = AddressAdd($addr, $offset);\n"
- " $last->[4] = $k;\n"
+ " $last->[4] = $k; # Store ending address for previous instruction\n"
" $last = [$k, $filename, $linenumber, $2, $end_addr];\n"
" push(@result, $last);\n"
" }\n"
@@ -945,13 +1340,21 @@ const char* pprof_perl() {
" close(OBJDUMP);\n"
" return @result;\n"
"}\n"
+ "\n"
+ "# The input file should contain lines of the form /proc/maps-like\n"
+ "# output (same format as expected from the profiles) or that looks\n"
+ "# like hex addresses (like \"0xDEADBEEF\"). We will parse all\n"
+ "# /proc/maps output, and for all the hex addresses, we will output\n"
+ "# \"short\" symbol names, one per line, in the same order as the input.\n"
"sub PrintSymbols {\n"
" my $maps_and_symbols_file = shift;\n"
- " my @pclist = ();\n"
+ "\n"
+ " # ParseLibraries expects pcs to be in a set. Fine by us...\n"
+ " my @pclist = (); # pcs in sorted order\n"
" my $pcs = {};\n"
" my $map = \"\";\n"
" foreach my $line (<$maps_and_symbols_file>) {\n"
- " $line =~ s/\\r//g;\n"
+ " $line =~ s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" if ($line =~ /\\b(0x[0-9a-f]+)\\b/i) {\n"
" push(@pclist, HexExtend($1));\n"
" $pcs->{$pclist[-1]} = 1;\n"
@@ -959,40 +1362,170 @@ const char* pprof_perl() {
" $map .= $line;\n"
" }\n"
" }\n"
+ "\n"
" my $libs = ParseLibraries($main::prog, $map, $pcs);\n"
" my $symbols = ExtractSymbols($libs, $pcs);\n"
+ "\n"
" foreach my $pc (@pclist) {\n"
+ " # ->[0] is the shortname, ->[2] is the full name\n"
" print(($symbols->{$pc}->[0] || \"\?\?\") . \"\\n\");\n"
" }\n"
"}\n"
+ "\n"
+ "\n"
+ "# For sorting functions by name\n"
"sub ByName {\n"
" return ShortFunctionName($a) cmp ShortFunctionName($b);\n"
"}\n"
+ "\n"
+ "# Print source-listing for all all routines that match $list_opts\n"
"sub PrintListing {\n"
+ " my $total = shift;\n"
" my $libs = shift;\n"
" my $flat = shift;\n"
" my $cumulative = shift;\n"
" my $list_opts = shift;\n"
+ " my $html = shift;\n"
+ "\n"
+ " my $output = \\*STDOUT;\n"
+ " my $fname = \"\";\n"
+ "\n"
+ " if ($html) {\n"
+ " # Arrange to write the output to a temporary file\n"
+ " $fname = TempName($main::next_tmpfile, \"html\");\n"
+ " $main::next_tmpfile++;\n"
+ " if (!open(TEMP, \">$fname\")) {\n"
+ " print STDERR \"$fname: $!\\n\";\n"
+ " return;\n"
+ " }\n"
+ " $output = \\*TEMP;\n"
+ " print $output HtmlListingHeader();\n"
+ " printf $output (\"<div class=\\\"legend\\\">%s<br>Total: %s %s</div>\\n\",\n"
+ " $main::prog, Unparse($total), Units());\n"
+ " }\n"
+ "\n"
+ " my $listed = 0;\n"
" foreach my $lib (@{$libs}) {\n"
" my $symbol_table = GetProcedureBoundaries($lib->[0], $list_opts);\n"
" my $offset = AddressSub($lib->[1], $lib->[3]);\n"
" foreach my $routine (sort ByName keys(%{$symbol_table})) {\n"
+ " # Print if there are any samples in this routine\n"
" my $start_addr = $symbol_table->{$routine}->[0];\n"
" my $end_addr = $symbol_table->{$routine}->[1];\n"
" my $length = hex(AddressSub($end_addr, $start_addr));\n"
" my $addr = AddressAdd($start_addr, $offset);\n"
" for (my $i = 0; $i < $length; $i++) {\n"
" if (defined($cumulative->{$addr})) {\n"
- " PrintSource($lib->[0], $offset,\n"
- " $routine, $flat, $cumulative,\n"
- " $start_addr, $end_addr);\n"
+ " $listed += PrintSource(\n"
+ " $lib->[0], $offset,\n"
+ " $routine, $flat, $cumulative,\n"
+ " $start_addr, $end_addr,\n"
+ " $html,\n"
+ " $output);\n"
" last;\n"
" }\n"
" $addr = AddressInc($addr);\n"
" }\n"
" }\n"
" }\n"
+ "\n"
+ " if ($html) {\n"
+ " if ($listed > 0) {\n"
+ " print $output HtmlListingFooter();\n"
+ " close($output);\n"
+ " RunWeb($fname);\n"
+ " } else {\n"
+ " close($output);\n"
+ " unlink($fname);\n"
+ " }\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "sub HtmlListingHeader {\n"
+ " return <<'EOF';\n"
+ "<DOCTYPE html>\n"
+ "<html>\n"
+ "<head>\n"
+ "<title>Pprof listing</title>\n"
+ "<style type=\"text/css\">\n"
+ "body {\n"
+ " font-family: sans-serif;\n"
+ "}\n"
+ "h1 {\n"
+ " font-size: 1.5em;\n"
+ " margin-bottom: 4px;\n"
+ "}\n"
+ ".legend {\n"
+ " font-size: 1.25em;\n"
+ "}\n"
+ ".line {\n"
+ " color: #aaaaaa;\n"
+ "}\n"
+ ".nop {\n"
+ " color: #aaaaaa;\n"
+ "}\n"
+ ".unimportant {\n"
+ " color: #cccccc;\n"
+ "}\n"
+ ".disasmloc {\n"
+ " color: #000000;\n"
+ "}\n"
+ ".deadsrc {\n"
+ " cursor: pointer;\n"
+ "}\n"
+ ".deadsrc:hover {\n"
+ " background-color: #eeeeee;\n"
+ "}\n"
+ ".livesrc {\n"
+ " color: #0000ff;\n"
+ " cursor: pointer;\n"
+ "}\n"
+ ".livesrc:hover {\n"
+ " background-color: #eeeeee;\n"
+ "}\n"
+ ".asm {\n"
+ " color: #008800;\n"
+ " display: none;\n"
+ "}\n"
+ "</style>\n"
+ "<script type=\"text/javascript\">\n"
+ "function pprof_toggle_asm(e) {\n"
+ " var target;\n"
+ " if (!e) e = window.event;\n"
+ " if (e.target) target = e.target;\n"
+ " else if (e.srcElement) target = e.srcElement;\n"
+ " if (target) {\n"
+ " var asm = target.nextSibling;\n"
+ " if (asm && asm.className == \"asm\") {\n"
+ " asm.style.display = (asm.style.display == \"block\" ? \"\" : \"block\");\n"
+ " e.preventDefault();\n"
+ " return false;\n"
+ " }\n"
+ " }\n"
+ "}\n"
+ "</script>\n"
+ "</head>\n"
+ "<body>\n"
+ "EOF\n"
"}\n"
+ "\n"
+ "sub HtmlListingFooter {\n"
+ " return <<'EOF';\n"
+ "</body>\n"
+ "</html>\n"
+ "EOF\n"
+ "}\n"
+ "\n"
+ "sub HtmlEscape {\n"
+ " my $text = shift;\n"
+ " $text =~ s/&/&/g;\n"
+ " $text =~ s/</</g;\n"
+ " $text =~ s/>/>/g;\n"
+ " return $text;\n"
+ "}\n"
+ "\n"
+ "# Returns the indentation of the line, if it has any non-whitespace\n"
+ "# characters. Otherwise, returns -1.\n"
"sub Indentation {\n"
" my $line = shift;\n"
" if (m/^(\\s*)\\S/) {\n"
@@ -1001,6 +1534,47 @@ const char* pprof_perl() {
" return -1;\n"
" }\n"
"}\n"
+ "\n"
+ "# If the symbol table contains inlining info, Disassemble() may tag an\n"
+ "# instruction with a location inside an inlined function. But for\n"
+ "# source listings, we prefer to use the location in the function we\n"
+ "# are listing. So use MapToSymbols() to fetch full location\n"
+ "# information for each instruction and then pick out the first\n"
+ "# location from a location list (location list contains callers before\n"
+ "# callees in case of inlining).\n"
+ "#\n"
+ "# After this routine has run, each entry in $instructions contains:\n"
+ "# [0] start address\n"
+ "# [1] filename for function we are listing\n"
+ "# [2] line number for function we are listing\n"
+ "# [3] disassembly\n"
+ "# [4] limit address\n"
+ "# [5] most specific filename (may be different from [1] due to inlining)\n"
+ "# [6] most specific line number (may be different from [2] due to inlining)\n"
+ "sub GetTopLevelLineNumbers {\n"
+ " my ($lib, $offset, $instructions) = @_;\n"
+ " my $pcs = [];\n"
+ " for (my $i = 0; $i <= $#{$instructions}; $i++) {\n"
+ " push(@{$pcs}, $instructions->[$i]->[0]);\n"
+ " }\n"
+ " my $symbols = {};\n"
+ " MapToSymbols($lib, $offset, $pcs, $symbols);\n"
+ " for (my $i = 0; $i <= $#{$instructions}; $i++) {\n"
+ " my $e = $instructions->[$i];\n"
+ " push(@{$e}, $e->[1]);\n"
+ " push(@{$e}, $e->[2]);\n"
+ " my $addr = $e->[0];\n"
+ " my $sym = $symbols->{$addr};\n"
+ " if (defined($sym)) {\n"
+ " if ($#{$sym} >= 2 && $sym->[1] =~ m/^(.*):(\\d+)$/) {\n"
+ " $e->[1] = $1; # File name\n"
+ " $e->[2] = $2; # Line number\n"
+ " }\n"
+ " }\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "# Print source-listing for one routine\n"
"sub PrintSource {\n"
" my $prog = shift;\n"
" my $offset = shift;\n"
@@ -1009,7 +1583,15 @@ const char* pprof_perl() {
" my $cumulative = shift;\n"
" my $start_addr = shift;\n"
" my $end_addr = shift;\n"
+ " my $html = shift;\n"
+ " my $output = shift;\n"
+ "\n"
+ " # Disassemble all instructions (just to get line numbers)\n"
" my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);\n"
+ " GetTopLevelLineNumbers($prog, $offset, \\@instructions);\n"
+ "\n"
+ " # Hack 1: assume that the first source file encountered in the\n"
+ " # disassembly contains the routine\n"
" my $filename = undef;\n"
" for (my $i = 0; $i <= $#instructions; $i++) {\n"
" if ($instructions[$i]->[2] >= 0) {\n"
@@ -1019,8 +1601,14 @@ const char* pprof_perl() {
" }\n"
" if (!defined($filename)) {\n"
" print STDERR \"no filename found in $routine\\n\";\n"
- " return;\n"
+ " return 0;\n"
" }\n"
+ "\n"
+ " # Hack 2: assume that the largest line number from $filename is the\n"
+ " # end of the procedure. This is typically safe since if P1 contains\n"
+ " # an inlined call to P2, then P2 usually occurs earlier in the\n"
+ " # source file. If this does not work, we might have to compute a\n"
+ " # density profile or just print all regions we find.\n"
" my $lastline = 0;\n"
" for (my $i = 0; $i <= $#instructions; $i++) {\n"
" my $f = $instructions[$i]->[1];\n"
@@ -1029,6 +1617,9 @@ const char* pprof_perl() {
" $lastline = $l;\n"
" }\n"
" }\n"
+ "\n"
+ " # Hack 3: assume the first source location from \"filename\" is the start of\n"
+ " # the source code.\n"
" my $firstline = 1;\n"
" for (my $i = 0; $i <= $#instructions; $i++) {\n"
" if ($instructions[$i]->[1] eq $filename) {\n"
@@ -1036,16 +1627,19 @@ const char* pprof_perl() {
" last;\n"
" }\n"
" }\n"
+ "\n"
+ " # Hack 4: Extend last line forward until its indentation is less than\n"
+ " # the indentation we saw on $firstline\n"
" my $oldlastline = $lastline;\n"
" {\n"
" if (!open(FILE, \"<$filename\")) {\n"
" print STDERR \"$filename: $!\\n\";\n"
- " return;\n"
+ " return 0;\n"
" }\n"
" my $l = 0;\n"
" my $first_indentation = -1;\n"
" while (<FILE>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" $l++;\n"
" my $indent = Indentation($_);\n"
" if ($l >= $firstline) {\n"
@@ -1064,19 +1658,68 @@ const char* pprof_perl() {
" }\n"
" close(FILE);\n"
" }\n"
- " my $samples1 = {};\n"
- " my $samples2 = {};\n"
- " my $running1 = 0;\n"
- " my $running2 = 0;\n"
- " my $total1 = 0;\n"
- " my $total2 = 0;\n"
+ "\n"
+ " # Assign all samples to the range $firstline,$lastline,\n"
+ " # Hack 4: If an instruction does not occur in the range, its samples\n"
+ " # are moved to the next instruction that occurs in the range.\n"
+ " my $samples1 = {}; # Map from line number to flat count\n"
+ " my $samples2 = {}; # Map from line number to cumulative count\n"
+ " my $running1 = 0; # Unassigned flat counts\n"
+ " my $running2 = 0; # Unassigned cumulative counts\n"
+ " my $total1 = 0; # Total flat counts\n"
+ " my $total2 = 0; # Total cumulative counts\n"
+ " my %disasm = (); # Map from line number to disassembly\n"
+ " my $running_disasm = \"\"; # Unassigned disassembly\n"
+ " my $skip_marker = \"---\\n\";\n"
+ " if ($html) {\n"
+ " $skip_marker = \"\";\n"
+ " for (my $l = $firstline; $l <= $lastline; $l++) {\n"
+ " $disasm{$l} = \"\";\n"
+ " }\n"
+ " }\n"
+ " my $last_dis_filename = '';\n"
+ " my $last_dis_linenum = -1;\n"
+ " my $last_touched_line = -1; # To detect gaps in disassembly for a line\n"
" foreach my $e (@instructions) {\n"
+ " # Add up counts for all address that fall inside this instruction\n"
" my $c1 = 0;\n"
" my $c2 = 0;\n"
" for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {\n"
" $c1 += GetEntry($flat, $a);\n"
" $c2 += GetEntry($cumulative, $a);\n"
" }\n"
+ "\n"
+ " if ($html) {\n"
+ " my $dis = sprintf(\" %6s %6s \\t\\t%8s: %s \",\n"
+ " HtmlPrintNumber($c1),\n"
+ " HtmlPrintNumber($c2),\n"
+ " UnparseAddress($offset, $e->[0]),\n"
+ " CleanDisassembly($e->[3]));\n"
+ " \n"
+ " # Append the most specific source line associated with this instruction\n"
+ " if (length($dis) < 80) { $dis .= (' ' x (80 - length($dis))) };\n"
+ " $dis = HtmlEscape($dis);\n"
+ " my $f = $e->[5];\n"
+ " my $l = $e->[6];\n"
+ " if ($f ne $last_dis_filename) {\n"
+ " $dis .= sprintf(\"<span class=disasmloc>%s:%d</span>\", \n"
+ " HtmlEscape(CleanFileName($f)), $l);\n"
+ " } elsif ($l ne $last_dis_linenum) {\n"
+ " # De-emphasize the unchanged file name portion\n"
+ " $dis .= sprintf(\"<span class=unimportant>%s</span>\" .\n"
+ " \"<span class=disasmloc>:%d</span>\", \n"
+ " HtmlEscape(CleanFileName($f)), $l);\n"
+ " } else {\n"
+ " # De-emphasize the entire location\n"
+ " $dis .= sprintf(\"<span class=unimportant>%s:%d</span>\", \n"
+ " HtmlEscape(CleanFileName($f)), $l);\n"
+ " }\n"
+ " $last_dis_filename = $f;\n"
+ " $last_dis_linenum = $l;\n"
+ " $running_disasm .= $dis;\n"
+ " $running_disasm .= \"\\n\";\n"
+ " }\n"
+ "\n"
" $running1 += $c1;\n"
" $running2 += $c2;\n"
" $total1 += $c1;\n"
@@ -1086,64 +1729,136 @@ const char* pprof_perl() {
" if (($file eq $filename) &&\n"
" ($line >= $firstline) &&\n"
" ($line <= $lastline)) {\n"
+ " # Assign all accumulated samples to this line\n"
" AddEntry($samples1, $line, $running1);\n"
" AddEntry($samples2, $line, $running2);\n"
" $running1 = 0;\n"
" $running2 = 0;\n"
+ " if ($html) {\n"
+ " if ($line != $last_touched_line && $disasm{$line} ne '') {\n"
+ " $disasm{$line} .= \"\\n\";\n"
+ " }\n"
+ " $disasm{$line} .= $running_disasm;\n"
+ " $running_disasm = '';\n"
+ " $last_touched_line = $line;\n"
+ " }\n"
" }\n"
" }\n"
+ "\n"
+ " # Assign any leftover samples to $lastline\n"
" AddEntry($samples1, $lastline, $running1);\n"
" AddEntry($samples2, $lastline, $running2);\n"
- " printf(\"ROUTINE ====================== %s in %s\\n\" .\n"
- " \"%6s %6s Total %s (flat / cumulative)\\n\",\n"
- " ShortFunctionName($routine),\n"
- " $filename,\n"
- " Units(),\n"
- " Unparse($total1),\n"
- " Unparse($total2));\n"
+ " if ($html) {\n"
+ " if ($lastline != $last_touched_line && $disasm{$lastline} ne '') {\n"
+ " $disasm{$lastline} .= \"\\n\";\n"
+ " }\n"
+ " $disasm{$lastline} .= $running_disasm;\n"
+ " }\n"
+ "\n"
+ " if ($html) {\n"
+ " printf $output (\n"
+ " \"<h1>%s</h1>%s\\n<pre onClick=\\\"pprof_toggle_asm()\\\">\\n\" .\n"
+ " \"Total:%6s %6s (flat / cumulative %s)\\n\",\n"
+ " HtmlEscape(ShortFunctionName($routine)),\n"
+ " HtmlEscape(CleanFileName($filename)),\n"
+ " Unparse($total1),\n"
+ " Unparse($total2),\n"
+ " Units());\n"
+ " } else {\n"
+ " printf $output (\n"
+ " \"ROUTINE ====================== %s in %s\\n\" .\n"
+ " \"%6s %6s Total %s (flat / cumulative)\\n\",\n"
+ " ShortFunctionName($routine),\n"
+ " CleanFileName($filename),\n"
+ " Unparse($total1),\n"
+ " Unparse($total2),\n"
+ " Units());\n"
+ " }\n"
" if (!open(FILE, \"<$filename\")) {\n"
" print STDERR \"$filename: $!\\n\";\n"
- " return;\n"
+ " return 0;\n"
" }\n"
" my $l = 0;\n"
" while (<FILE>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" $l++;\n"
" if ($l >= $firstline - 5 &&\n"
" (($l <= $oldlastline + 5) || ($l <= $lastline))) {\n"
" chop;\n"
" my $text = $_;\n"
- " if ($l == $firstline) { printf(\"---\\n\"); }\n"
- " printf(\"%6s %6s %4d: %s\\n\",\n"
- " UnparseAlt(GetEntry($samples1, $l)),\n"
- " UnparseAlt(GetEntry($samples2, $l)),\n"
- " $l,\n"
- " $text);\n"
- " if ($l == $lastline) { printf(\"---\\n\"); }\n"
+ " if ($l == $firstline) { print $output $skip_marker; }\n"
+ " my $n1 = GetEntry($samples1, $l);\n"
+ " my $n2 = GetEntry($samples2, $l);\n"
+ " if ($html) {\n"
+ " # Emit a span that has one of the following classes:\n"
+ " # livesrc -- has samples\n"
+ " # deadsrc -- has disassembly, but with no samples\n"
+ " # nop -- has no matching disasembly\n"
+ " # Also emit an optional span containing disassembly.\n"
+ " my $dis = $disasm{$l};\n"
+ " my $asm = \"\";\n"
+ " if (defined($dis) && $dis ne '') {\n"
+ " $asm = \"<span class=\\\"asm\\\">\" . $dis . \"</span>\";\n"
+ " }\n"
+ " my $source_class = (($n1 + $n2 > 0) \n"
+ " ? \"livesrc\" \n"
+ " : (($asm ne \"\") ? \"deadsrc\" : \"nop\"));\n"
+ " printf $output (\n"
+ " \"<span class=\\\"line\\\">%5d</span> \" .\n"
+ " \"<span class=\\\"%s\\\">%6s %6s %s</span>%s\\n\",\n"
+ " $l, $source_class,\n"
+ " HtmlPrintNumber($n1),\n"
+ " HtmlPrintNumber($n2),\n"
+ " HtmlEscape($text),\n"
+ " $asm);\n"
+ " } else {\n"
+ " printf $output(\n"
+ " \"%6s %6s %4d: %s\\n\",\n"
+ " UnparseAlt($n1),\n"
+ " UnparseAlt($n2),\n"
+ " $l,\n"
+ " $text);\n"
+ " }\n"
+ " if ($l == $lastline) { print $output $skip_marker; }\n"
" };\n"
" }\n"
" close(FILE);\n"
+ " if ($html) {\n"
+ " print $output \"</pre>\\n\";\n"
+ " }\n"
+ " return 1;\n"
"}\n"
+ "\n"
+ "# Return the source line for the specified file/linenumber.\n"
+ "# Returns undef if not found.\n"
"sub SourceLine {\n"
" my $file = shift;\n"
" my $line = shift;\n"
+ "\n"
+ " # Look in cache\n"
" if (!defined($main::source_cache{$file})) {\n"
" if (100 < scalar keys(%main::source_cache)) {\n"
+ " # Clear the cache when it gets too big\n"
" $main::source_cache = ();\n"
" }\n"
+ "\n"
+ " # Read all lines from the file\n"
" if (!open(FILE, \"<$file\")) {\n"
" print STDERR \"$file: $!\\n\";\n"
- " $main::source_cache{$file} = [];\n"
+ " $main::source_cache{$file} = []; # Cache the negative result\n"
" return undef;\n"
" }\n"
" my $lines = [];\n"
- " push(@{$lines}, \"\");\n"
+ " push(@{$lines}, \"\"); # So we can use 1-based line numbers as indices\n"
" while (<FILE>) {\n"
" push(@{$lines}, $_);\n"
" }\n"
" close(FILE);\n"
+ "\n"
+ " # Save the lines in the cache\n"
" $main::source_cache{$file} = $lines;\n"
" }\n"
+ "\n"
" my $lines = $main::source_cache{$file};\n"
" if (($line < 0) || ($line > $#{$lines})) {\n"
" return undef;\n"
@@ -1151,6 +1866,8 @@ const char* pprof_perl() {
" return $lines->[$line];\n"
" }\n"
"}\n"
+ "\n"
+ "# Print disassembly for one routine with interspersed source if available\n"
"sub PrintDisassembledFunction {\n"
" my $prog = shift;\n"
" my $offset = shift;\n"
@@ -1160,12 +1877,17 @@ const char* pprof_perl() {
" my $start_addr = shift;\n"
" my $end_addr = shift;\n"
" my $total = shift;\n"
+ "\n"
+ " # Disassemble all instructions\n"
" my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);\n"
+ "\n"
+ " # Make array of counts per instruction\n"
" my @flat_count = ();\n"
" my @cum_count = ();\n"
" my $flat_total = 0;\n"
" my $cum_total = 0;\n"
" foreach my $e (@instructions) {\n"
+ " # Add up counts for all address that fall inside this instruction\n"
" my $c1 = 0;\n"
" my $c2 = 0;\n"
" for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {\n"
@@ -1177,6 +1899,8 @@ const char* pprof_perl() {
" $flat_total += $c1;\n"
" $cum_total += $c2;\n"
" }\n"
+ "\n"
+ " # Print header with total counts\n"
" printf(\"ROUTINE ====================== %s\\n\" .\n"
" \"%6s %6s %s (flat, cumulative) %.1f%% of total\\n\",\n"
" ShortFunctionName($routine),\n"
@@ -1184,18 +1908,27 @@ const char* pprof_perl() {
" Unparse($cum_total),\n"
" Units(),\n"
" ($cum_total * 100.0) / $total);\n"
+ "\n"
+ " # Process instructions in order\n"
" my $current_file = \"\";\n"
" for (my $i = 0; $i <= $#instructions; ) {\n"
" my $e = $instructions[$i];\n"
+ "\n"
+ " # Print the new file name whenever we switch files\n"
" if ($e->[1] ne $current_file) {\n"
" $current_file = $e->[1];\n"
" my $fname = $current_file;\n"
- " $fname =~ s|^\\./||;\n"
+ " $fname =~ s|^\\./||; # Trim leading \"./\"\n"
+ "\n"
+ " # Shorten long file names\n"
" if (length($fname) >= 58) {\n"
" $fname = \"...\" . substr($fname, -55);\n"
" }\n"
" printf(\"-------------------- %s\\n\", $fname);\n"
" }\n"
+ "\n"
+ " # TODO: Compute range of lines to print together to deal with\n"
+ " # small reorderings.\n"
" my $first_line = $e->[2];\n"
" my $last_line = $first_line;\n"
" my %flat_sum = ();\n"
@@ -1204,6 +1937,8 @@ const char* pprof_perl() {
" $flat_sum{$l} = 0;\n"
" $cum_sum{$l} = 0;\n"
" }\n"
+ "\n"
+ " # Find run of instructions for this range of source lines\n"
" my $first_inst = $i;\n"
" while (($i <= $#instructions) &&\n"
" ($instructions[$i]->[2] >= $first_line) &&\n"
@@ -1214,6 +1949,8 @@ const char* pprof_perl() {
" $i++;\n"
" }\n"
" my $last_inst = $i - 1;\n"
+ "\n"
+ " # Print source lines\n"
" for (my $l = $first_line; $l <= $last_line; $l++) {\n"
" my $line = SourceLine($current_file, $l);\n"
" if (!defined($line)) {\n"
@@ -1228,23 +1965,20 @@ const char* pprof_perl() {
" $l,\n"
" $line);\n"
" }\n"
+ "\n"
+ " # Print disassembly\n"
" for (my $x = $first_inst; $x <= $last_inst; $x++) {\n"
" my $e = $instructions[$x];\n"
- " my $address = $e->[0];\n"
- " $address = AddressSub($address, $offset);\n"
- " $address =~ s/^0x//;\n"
- " $address =~ s/^0*//;\n"
- " my $d = $e->[3];\n"
- " while ($d =~ s/\\([^()%]*\\)(\\s*const)?//g) { }\n"
- " while ($d =~ s/(\\w+)<[^<>]*>/$1/g) { }\n"
" printf(\"%6s %6s %8s: %6s\\n\",\n"
" UnparseAlt($flat_count[$x]),\n"
" UnparseAlt($cum_count[$x]),\n"
- " $address,\n"
- " $d);\n"
+ " UnparseAddress($offset, $e->[0]),\n"
+ " CleanDisassembly($e->[3]));\n"
" }\n"
" }\n"
"}\n"
+ "\n"
+ "# Print DOT graph\n"
"sub PrintDot {\n"
" my $prog = shift;\n"
" my $symbols = shift;\n"
@@ -1252,10 +1986,14 @@ const char* pprof_perl() {
" my $flat = shift;\n"
" my $cumulative = shift;\n"
" my $overall_total = shift;\n"
+ "\n"
+ " # Get total\n"
" my $local_total = TotalProfile($flat);\n"
" my $nodelimit = int($main::opt_nodefraction * $local_total);\n"
" my $edgelimit = int($main::opt_edgefraction * $local_total);\n"
" my $nodecount = $main::opt_nodecount;\n"
+ "\n"
+ " # Find nodes to include\n"
" my @list = (sort { abs(GetEntry($cumulative, $b)) <=>\n"
" abs(GetEntry($cumulative, $a))\n"
" || $a cmp $b }\n"
@@ -1272,35 +2010,51 @@ const char* pprof_perl() {
" print STDERR \"No nodes to print\\n\";\n"
" return 0;\n"
" }\n"
+ "\n"
" if ($nodelimit > 0 || $edgelimit > 0) {\n"
" printf STDERR (\"Dropping nodes with <= %s %s; edges with <= %s abs(%s)\\n\",\n"
" Unparse($nodelimit), Units(),\n"
" Unparse($edgelimit), Units());\n"
" }\n"
+ "\n"
+ " # Open DOT output file\n"
" my $output;\n"
+ " my $escaped_dot = ShellEscape(@DOT);\n"
+ " my $escaped_ps2pdf = ShellEscape(@PS2PDF);\n"
" if ($main::opt_gv) {\n"
- " $output = \"| $DOT -Tps2 >\" . TempName($main::next_tmpfile, \"ps\");\n"
+ " my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, \"ps\"));\n"
+ " $output = \"| $escaped_dot -Tps2 >$escaped_outfile\";\n"
+ " } elsif ($main::opt_evince) {\n"
+ " my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, \"pdf\"));\n"
+ " $output = \"| $escaped_dot -Tps2 | $escaped_ps2pdf - $escaped_outfile\";\n"
" } elsif ($main::opt_ps) {\n"
- " $output = \"| $DOT -Tps2\";\n"
+ " $output = \"| $escaped_dot -Tps2\";\n"
" } elsif ($main::opt_pdf) {\n"
- " $output = \"| $DOT -Tps2 | $PS2PDF - -\";\n"
+ " $output = \"| $escaped_dot -Tps2 | $escaped_ps2pdf - -\";\n"
" } elsif ($main::opt_web || $main::opt_svg) {\n"
- " $output = \"| $DOT -Tsvg >\" . TempName($main::next_tmpfile, \"svg\");\n"
+ " # We need to post-process the SVG, so write to a temporary file always.\n"
+ " my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, \"svg\"));\n"
+ " $output = \"| $escaped_dot -Tsvg >$escaped_outfile\";\n"
" } elsif ($main::opt_gif) {\n"
- " $output = \"| $DOT -Tgif\";\n"
+ " $output = \"| $escaped_dot -Tgif\";\n"
" } else {\n"
" $output = \">&STDOUT\";\n"
" }\n"
" open(DOT, $output) || error(\"$output: $!\\n\");\n"
+ "\n"
+ " # Title\n"
" printf DOT (\"digraph \\\"%s; %s %s\\\" {\\n\",\n"
" $prog,\n"
" Unparse($overall_total),\n"
" Units());\n"
" if ($main::opt_pdf) {\n"
+ " # The output is more printable if we set the page size for dot.\n"
" printf DOT (\"size=\\\"8,11\\\"\\n\");\n"
" }\n"
" printf DOT (\"node [width=0.375,height=0.25];\\n\");\n"
- " printf DOT (\"Legend [shape=box,fontsize=20,shape=plaintext,\" .\n"
+ "\n"
+ " # Print legend\n"
+ " printf DOT (\"Legend [shape=box,fontsize=24,shape=plaintext,\" .\n"
" \"label=\\\"%s\\\\l%s\\\\l%s\\\\l%s\\\\l%s\\\\l\\\"];\\n\",\n"
" $prog,\n"
" sprintf(\"Total %s: %s\", Units(), Unparse($overall_total)),\n"
@@ -1310,53 +2064,69 @@ const char* pprof_perl() {
" sprintf(\"Dropped edges with <= %s %s\",\n"
" Unparse($edgelimit), Units())\n"
" );\n"
+ "\n"
+ " # Print nodes\n"
" my %node = ();\n"
" my $nextnode = 1;\n"
" foreach my $a (@list[0..$last]) {\n"
+ " # Pick font size\n"
" my $f = GetEntry($flat, $a);\n"
" my $c = GetEntry($cumulative, $a);\n"
+ "\n"
" my $fs = 8;\n"
" if ($local_total > 0) {\n"
" $fs = 8 + (50.0 * sqrt(abs($f * 1.0 / $local_total)));\n"
" }\n"
+ "\n"
" $node{$a} = $nextnode++;\n"
" my $sym = $a;\n"
" $sym =~ s/\\s+/\\\\n/g;\n"
" $sym =~ s/::/\\\\n/g;\n"
+ "\n"
+ " # Extra cumulative info to print for non-leaves\n"
" my $extra = \"\";\n"
" if ($f != $c) {\n"
" $extra = sprintf(\"\\\\rof %s (%s)\",\n"
" Unparse($c),\n"
- " Percent($c, $overall_total));\n"
+ " Percent($c, $local_total));\n"
" }\n"
" my $style = \"\";\n"
" if ($main::opt_heapcheck) {\n"
" if ($f > 0) {\n"
+ " # make leak-causing nodes more visible (add a background)\n"
" $style = \",style=filled,fillcolor=gray\"\n"
" } elsif ($f < 0) {\n"
+ " # make anti-leak-causing nodes (which almost never occur)\n"
+ " # stand out as well (triple border)\n"
" $style = \",peripheries=3\"\n"
" }\n"
" }\n"
+ "\n"
" printf DOT (\"N%d [label=\\\"%s\\\\n%s (%s)%s\\\\r\" .\n"
" \"\\\",shape=box,fontsize=%.1f%s];\\n\",\n"
" $node{$a},\n"
" $sym,\n"
" Unparse($f),\n"
- " Percent($f, $overall_total),\n"
+ " Percent($f, $local_total),\n"
" $extra,\n"
" $fs,\n"
" $style,\n"
" );\n"
" }\n"
+ "\n"
+ " # Get edges and counts per edge\n"
" my %edge = ();\n"
" my $n;\n"
+ " my $fullname_to_shortname_map = {};\n"
+ " FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);\n"
" foreach my $k (keys(%{$raw})) {\n"
+ " # TODO: omit low %age edges\n"
" $n = $raw->{$k};\n"
- " my @translated = TranslateStack($symbols, $k);\n"
+ " my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);\n"
" for (my $i = 1; $i <= $#translated; $i++) {\n"
" my $src = $translated[$i];\n"
" my $dst = $translated[$i-1];\n"
- " #next if ($src eq $dst);\n"
+ " #next if ($src eq $dst); # Avoid self-edges?\n"
" if (exists($node{$src}) && exists($node{$dst})) {\n"
" my $edge_label = \"$src\\001$dst\";\n"
" if (!exists($edge{$edge_label})) {\n"
@@ -1366,24 +2136,60 @@ const char* pprof_perl() {
" }\n"
" }\n"
" }\n"
- " foreach my $e (keys(%edge)) {\n"
+ "\n"
+ " # Print edges (process in order of decreasing counts)\n"
+ " my %indegree = (); # Number of incoming edges added per node so far\n"
+ " my %outdegree = (); # Number of outgoing edges added per node so far\n"
+ " foreach my $e (sort { $edge{$b} <=> $edge{$a} } keys(%edge)) {\n"
" my @x = split(/\\001/, $e);\n"
" $n = $edge{$e};\n"
- " if (abs($n) > $edgelimit) {\n"
+ "\n"
+ " # Initialize degree of kept incoming and outgoing edges if necessary\n"
+ " my $src = $x[0];\n"
+ " my $dst = $x[1];\n"
+ " if (!exists($outdegree{$src})) { $outdegree{$src} = 0; }\n"
+ " if (!exists($indegree{$dst})) { $indegree{$dst} = 0; }\n"
+ "\n"
+ " my $keep;\n"
+ " if ($indegree{$dst} == 0) {\n"
+ " # Keep edge if needed for reachability\n"
+ " $keep = 1;\n"
+ " } elsif (abs($n) <= $edgelimit) {\n"
+ " # Drop if we are below --edgefraction\n"
+ " $keep = 0;\n"
+ " } elsif ($outdegree{$src} >= $main::opt_maxdegree ||\n"
+ " $indegree{$dst} >= $main::opt_maxdegree) {\n"
+ " # Keep limited number of in/out edges per node\n"
+ " $keep = 0;\n"
+ " } else {\n"
+ " $keep = 1;\n"
+ " }\n"
+ "\n"
+ " if ($keep) {\n"
+ " $outdegree{$src}++;\n"
+ " $indegree{$dst}++;\n"
+ "\n"
+ " # Compute line width based on edge count\n"
" my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0);\n"
" if ($fraction > 1) { $fraction = 1; }\n"
" my $w = $fraction * 2;\n"
- " if ($w < 0.5 && ($main::opt_dot || $main::opt_web || $main::opt_svg)) {\n"
- // NOTE: We transfer dot to svg at browser side, also need to limit width for dot.
- " $w = 0.5;\n"
+ " if ($w < 1 && ($main::opt_web || $main::opt_svg)) {\n"
+ " # SVG output treats line widths < 1 poorly.\n"
+ " $w = 1;\n"
" }\n"
+ "\n"
+ " # Dot sometimes segfaults if given edge weights that are too large, so\n"
+ " # we cap the weights at a large value\n"
" my $edgeweight = abs($n) ** 0.7;\n"
" if ($edgeweight > 100000) { $edgeweight = 100000; }\n"
" $edgeweight = int($edgeweight);\n"
+ "\n"
" my $style = sprintf(\"setlinewidth(%f)\", $w);\n"
" if ($x[1] =~ m/\\(inline\\)/) {\n"
" $style .= \",dashed\";\n"
" }\n"
+ "\n"
+ " # Use a slightly squashed function of the edge count as the weight\n"
" printf DOT (\"N%s -> N%s [label=%s, weight=%d, style=\\\"%s\\\"];\\n\",\n"
" $node{$x[0]},\n"
" $node{$x[1]},\n"
@@ -1392,37 +2198,72 @@ const char* pprof_perl() {
" $style);\n"
" }\n"
" }\n"
+ "\n"
" print DOT (\"}\\n\");\n"
" close(DOT);\n"
+ "\n"
" if ($main::opt_web || $main::opt_svg) {\n"
+ " # Rewrite SVG to be more usable inside web browser.\n"
" RewriteSvg(TempName($main::next_tmpfile, \"svg\"));\n"
" }\n"
+ "\n"
" return 1;\n"
"}\n"
+ "\n"
"sub RewriteSvg {\n"
" my $svgfile = shift;\n"
+ "\n"
" open(SVG, $svgfile) || die \"open temp svg: $!\";\n"
" my @svg = <SVG>;\n"
" close(SVG);\n"
" unlink $svgfile;\n"
" my $svg = join('', @svg);\n"
+ "\n"
+ " # Dot's SVG output is\n"
" #\n"
+ " # <svg width=\"___\" height=\"___\"\n"
+ " # viewBox=\"___\" xmlns=...>\n"
+ " # <g id=\"graph0\" transform=\"...\">\n"
+ " # ...\n"
+ " # </g>\n"
+ " # </svg>\n"
" #\n"
+ " # Change it to\n"
" #\n"
- " $svg =~ s/(?s)<svg width=\"[^\"]+\" height=\"[^\"]+\"(.*?)viewBox=\"[^\"]+\"/<svg width=\"100%\" height=\"100%\"$1/;\n"
+ " # <svg width=\"100%\" height=\"100%\"\n"
+ " # xmlns=...>\n"
+ " # $svg_javascript\n"
+ " # <g id=\"viewport\" transform=\"translate(0,0)\">\n"
+ " # <g id=\"graph0\" transform=\"...\">\n"
+ " # ...\n"
+ " # </g>\n"
+ " # </g>\n"
+ " # </svg>\n"
+ "\n"
+ " # Fix width, height; drop viewBox.\n"
+ " $svg =~ s/(?s)<svg width=\"[^\"]+\" height=\"[^\"]+\"(.*?)viewBox=\"[^\"]+\"/<svg "
+ "width=\"100%\" height=\"100%\"$1/;\n"
+ "\n"
+ " # Insert script, viewport <g> above first <g>\n"
" my $svg_javascript = SvgJavascript();\n"
" my $viewport = \"<g id=\\\"viewport\\\" transform=\\\"translate(0,0)\\\">\\n\";\n"
" $svg =~ s/<g id=\"graph\\d\"/$svg_javascript$viewport$&/;\n"
+ "\n"
+ " # Insert final </g> above </svg>.\n"
" $svg =~ s/(.*)(<\\/svg>)/$1<\\/g>$2/;\n"
" $svg =~ s/<g id=\"graph\\d\"(.*?)/<g id=\"viewport\"$1/;\n"
+ "\n"
" if ($main::opt_svg) {\n"
+ " # --svg: write to standard output.\n"
" print $svg;\n"
" } else {\n"
+ " # Write back to temporary file.\n"
" open(SVG, \">$svgfile\") || die \"open $svgfile: $!\";\n"
" print SVG $svg;\n"
" close(SVG);\n"
" }\n"
"}\n"
+ "\n"
"sub SvgJavascript {\n"
" return <<'EOF';\n"
"<script type=\"text/ecmascript\"><![CDATA[\n"
@@ -1457,30 +2298,43 @@ const char* pprof_perl() {
" *\n"
" * This code is licensed under the following BSD license:\n"
" *\n"
- " * Copyright 2009-2010 Andrea Leofreddi <a....@itcharm.com>. All rights reserved.\n"
+ " * Copyright 2009-2010 Andrea Leofreddi <a....@itcharm.com>. All rights "
+ "reserved.\n"
" *\n"
- " * Redistribution and use in source and binary forms, with or without modification, are\n"
+ " * Redistribution and use in source and binary forms, with or without modification, "
+ "are\n"
" * permitted provided that the following conditions are met:\n"
" *\n"
- " * 1. Redistributions of source code must retain the above copyright notice, this list of\n"
+ " * 1. Redistributions of source code must retain the above copyright notice, this "
+ "list of\n"
" * conditions and the following disclaimer.\n"
" *\n"
- " * 2. Redistributions in binary form must reproduce the above copyright notice, this list\n"
- " * of conditions and the following disclaimer in the documentation and/or other materials\n"
+ " * 2. Redistributions in binary form must reproduce the above copyright notice, "
+ "this list\n"
+ " * of conditions and the following disclaimer in the documentation and/or other "
+ "materials\n"
" * provided with the distribution.\n"
" *\n"
" * THIS SOFTWARE IS PROVIDED BY Andrea Leofreddi ``AS IS'' AND ANY EXPRESS OR IMPLIED\n"
- " * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND\n"
- " * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Andrea Leofreddi OR\n"
- " * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR\n"
- " * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR\n"
- " * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON\n"
+ " * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF "
+ "MERCHANTABILITY AND\n"
+ " * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Andrea Leofreddi "
+ "OR\n"
+ " * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, "
+ "OR\n"
+ " * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE "
+ "GOODS OR\n"
+ " * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED "
+ "AND ON\n"
" * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING\n"
- " * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF\n"
+ " * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN "
+ "IF\n"
" * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.\n"
" *\n"
- " * The views and conclusions contained in the software and documentation are those of the\n"
- " * authors and should not be interpreted as representing official policies, either expressed\n"
+ " * The views and conclusions contained in the software and documentation are those of "
+ "the\n"
+ " * authors and should not be interpreted as representing official policies, either "
+ "expressed\n"
" * or implied, of Andrea Leofreddi.\n"
" */\n"
"var root = document.documentElement;\n"
@@ -1495,12 +2349,15 @@ const char* pprof_perl() {
" \"onmousedown\" : \"handleMouseDown(evt)\",\n"
" \"onmousemove\" : \"handleMouseMove(evt)\",\n"
" \"onmouseup\" : \"handleMouseUp(evt)\",\n"
- " //\"onmouseout\" : \"handleMouseUp(evt)\", // Decomment this to stop the pan functionality when dragging out of the SVG element\n"
+ " //\"onmouseout\" : \"handleMouseUp(evt)\", // Decomment this to stop the "
+ "pan functionality when dragging out of the SVG element\n"
" });\n"
" if(navigator.userAgent.toLowerCase().indexOf('webkit') >= 0)\n"
- " window.addEventListener('mousewheel', handleMouseWheel, false); // Chrome/Safari\n"
+ " window.addEventListener('mousewheel', handleMouseWheel, false); // "
+ "Chrome/Safari\n"
" else\n"
- " window.addEventListener('DOMMouseScroll', handleMouseWheel, false); // Others\n"
+ " window.addEventListener('DOMMouseScroll', handleMouseWheel, false); // "
+ "Others\n"
" var g = svgDoc.getElementById(\"svg\");\n"
" g.width = \"100%\";\n"
" g.height = \"100%\";\n"
@@ -1518,14 +2375,16 @@ const char* pprof_perl() {
" * Sets the current transform matrix of an element.\n"
" */\n"
"function setCTM(element, matrix) {\n"
- " var s = \"matrix(\" + matrix.a + \",\" + matrix.b + \",\" + matrix.c + \",\" + matrix.d + \",\" + matrix.e + \",\" + matrix.f + \")\";\n"
+ " var s = \"matrix(\" + matrix.a + \",\" + matrix.b + \",\" + matrix.c + \",\" + "
+ "matrix.d + \",\" + matrix.e + \",\" + matrix.f + \")\";\n"
" element.setAttribute(\"transform\", s);\n"
"}\n"
"/**\n"
" * Dumps a matrix to a string (useful for debug).\n"
" */\n"
"function dumpMatrix(matrix) {\n"
- " var s = \"[ \" + matrix.a + \", \" + matrix.c + \", \" + matrix.e + \"\\n \" + matrix.b + \", \" + matrix.d + \", \" + matrix.f + \"\\n 0, 0, 1 ]\";\n"
+ " var s = \"[ \" + matrix.a + \", \" + matrix.c + \", \" + matrix.e + \"\\n \" + "
+ "matrix.b + \", \" + matrix.d + \", \" + matrix.f + \"\\n 0, 0, 1 ]\";\n"
" return s;\n"
"}\n"
"/**\n"
@@ -1553,7 +2412,8 @@ const char* pprof_perl() {
" var p = getEventPoint(evt);\n"
" p = p.matrixTransform(g.getCTM().inverse());\n"
" // Compute new scale matrix in current mouse position\n"
- " var k = root.createSVGMatrix().translate(p.x, p.y).scale(z).translate(-p.x, -p.y);\n"
+ " var k = root.createSVGMatrix().translate(p.x, p.y).scale(z).translate(-p.x, "
+ "-p.y);\n"
" setCTM(g, g.getCTM().multiply(k));\n"
" stateTf = stateTf.multiply(k.inverse());\n"
"}\n"
@@ -1569,11 +2429,13 @@ const char* pprof_perl() {
" if(state == 'pan') {\n"
" // Pan mode\n"
" var p = getEventPoint(evt).matrixTransform(stateTf);\n"
- " setCTM(g, stateTf.inverse().translate(p.x - stateOrigin.x, p.y - stateOrigin.y));\n"
+ " setCTM(g, stateTf.inverse().translate(p.x - stateOrigin.x, p.y - "
+ "stateOrigin.y));\n"
" } else if(state == 'move') {\n"
" // Move mode\n"
" var p = getEventPoint(evt).matrixTransform(g.getCTM().inverse());\n"
- " setCTM(stateTarget, root.createSVGMatrix().translate(p.x - stateOrigin.x, p.y - stateOrigin.y).multiply(g.getCTM().inverse()).multiply(stateTarget.getCTM()));\n"
+ " setCTM(stateTarget, root.createSVGMatrix().translate(p.x - stateOrigin.x, "
+ "p.y - stateOrigin.y).multiply(g.getCTM().inverse()).multiply(stateTarget.getCTM()));\n"
" stateOrigin = p;\n"
" }\n"
"}\n"
@@ -1615,44 +2477,131 @@ const char* pprof_perl() {
"]]></script>\n"
"EOF\n"
"}\n"
+ "\n"
+ "# Provides a map from fullname to shortname for cases where the\n"
+ "# shortname is ambiguous. The symlist has both the fullname and\n"
+ "# shortname for all symbols, which is usually fine, but sometimes --\n"
+ "# such as overloaded functions -- two different fullnames can map to\n"
+ "# the same shortname. In that case, we use the address of the\n"
+ "# function to disambiguate the two. This function fills in a map that\n"
+ "# maps fullnames to modified shortnames in such cases. If a fullname\n"
+ "# is not present in the map, the 'normal' shortname provided by the\n"
+ "# symlist is the appropriate one to use.\n"
+ "sub FillFullnameToShortnameMap {\n"
+ " my $symbols = shift;\n"
+ " my $fullname_to_shortname_map = shift;\n"
+ " my $shortnames_seen_once = {};\n"
+ " my $shortnames_seen_more_than_once = {};\n"
+ "\n"
+ " foreach my $symlist (values(%{$symbols})) {\n"
+ " # TODO(csilvers): deal with inlined symbols too.\n"
+ " my $shortname = $symlist->[0];\n"
+ " my $fullname = $symlist->[2];\n"
+ " if ($fullname !~ /<[0-9a-fA-F]+>$/) { # fullname doesn't end in an address\n"
+ " next; # the only collisions we care about are when addresses differ\n"
+ " }\n"
+ " if (defined($shortnames_seen_once->{$shortname}) &&\n"
+ " $shortnames_seen_once->{$shortname} ne $fullname) {\n"
+ " $shortnames_seen_more_than_once->{$shortname} = 1;\n"
+ " } else {\n"
+ " $shortnames_seen_once->{$shortname} = $fullname;\n"
+ " }\n"
+ " }\n"
+ "\n"
+ " foreach my $symlist (values(%{$symbols})) {\n"
+ " my $shortname = $symlist->[0];\n"
+ " my $fullname = $symlist->[2];\n"
+ " # TODO(csilvers): take in a list of addresses we care about, and only\n"
+ " # store in the map if $symlist->[1] is in that list. Saves space.\n"
+ " next if defined($fullname_to_shortname_map->{$fullname});\n"
+ " if (defined($shortnames_seen_more_than_once->{$shortname})) {\n"
+ " if ($fullname =~ /<0*([^>]*)>$/) { # fullname has address at end of it\n"
+ " $fullname_to_shortname_map->{$fullname} = \"$shortname\\@$1\";\n"
+ " }\n"
+ " }\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "# Return a small number that identifies the argument.\n"
+ "# Multiple calls with the same argument will return the same number.\n"
+ "# Calls with different arguments will return different numbers.\n"
+ "sub ShortIdFor {\n"
+ " my $key = shift;\n"
+ " my $id = $main::uniqueid{$key};\n"
+ " if (!defined($id)) {\n"
+ " $id = keys(%main::uniqueid) + 1;\n"
+ " $main::uniqueid{$key} = $id;\n"
+ " }\n"
+ " return $id;\n"
+ "}\n"
+ "\n"
+ "# Translate a stack of addresses into a stack of symbols\n"
"sub TranslateStack {\n"
" my $symbols = shift;\n"
+ " my $fullname_to_shortname_map = shift;\n"
" my $k = shift;\n"
+ "\n"
" my @addrs = split(/\\n/, $k);\n"
" my @result = ();\n"
" for (my $i = 0; $i <= $#addrs; $i++) {\n"
" my $a = $addrs[$i];\n"
+ "\n"
+ " # Skip large addresses since they sometimes show up as fake entries on RH9\n"
" if (length($a) > 8 && $a gt \"7fffffffffffffff\") {\n"
" next;\n"
" }\n"
+ "\n"
" if ($main::opt_disasm || $main::opt_list) {\n"
+ " # We want just the address for the key\n"
" push(@result, $a);\n"
" next;\n"
" }\n"
+ "\n"
" my $symlist = $symbols->{$a};\n"
" if (!defined($symlist)) {\n"
" $symlist = [$a, \"\", $a];\n"
" }\n"
+ "\n"
+ " # We can have a sequence of symbols for a particular entry\n"
+ " # (more than one symbol in the case of inlining). Callers\n"
+ " # come before callees in symlist, so walk backwards since\n"
+ " # the translated stack should contain callees before callers.\n"
" for (my $j = $#{$symlist}; $j >= 2; $j -= 3) {\n"
" my $func = $symlist->[$j-2];\n"
" my $fileline = $symlist->[$j-1];\n"
" my $fullfunc = $symlist->[$j];\n"
+ " if (defined($fullname_to_shortname_map->{$fullfunc})) {\n"
+ " $func = $fullname_to_shortname_map->{$fullfunc};\n"
+ " }\n"
" if ($j > 2) {\n"
" $func = \"$func (inline)\";\n"
" }\n"
+ "\n"
+ " # Do not merge nodes corresponding to Callback::Run since that\n"
+ " # causes confusing cycles in dot display. Instead, we synthesize\n"
+ " # a unique name for this frame per caller.\n"
+ " if ($func =~ m/Callback.*::Run$/) {\n"
+ " my $caller = ($i > 0) ? $addrs[$i-1] : 0;\n"
+ " $func = \"Run#\" . ShortIdFor($caller);\n"
+ " }\n"
+ "\n"
" if ($main::opt_addresses) {\n"
" push(@result, \"$a $func $fileline\");\n"
" } elsif ($main::opt_lines) {\n"
" if ($func eq '\?\?' && $fileline eq '\?\?:0') {\n"
" push(@result, \"$a\");\n"
- " } else {\n"
+ " } elsif (!$main::opt_show_addresses) {\n"
" push(@result, \"$func $fileline\");\n"
+ " } else {\n"
+ " push(@result, \"$func $fileline ($a)\");\n"
" }\n"
" } elsif ($main::opt_functions) {\n"
" if ($func eq '\?\?') {\n"
" push(@result, \"$a\");\n"
- " } else {\n"
+ " } elsif (!$main::opt_show_addresses) {\n"
" push(@result, $func);\n"
+ " } else {\n"
+ " push(@result, \"$func ($a)\");\n"
" }\n"
" } elsif ($main::opt_files) {\n"
" if ($fileline eq '\?\?:0' || $fileline eq '') {\n"
@@ -1664,12 +2613,16 @@ const char* pprof_perl() {
" }\n"
" } else {\n"
" push(@result, $a);\n"
- " last;\n"
+ " last; # Do not print inlined info\n"
" }\n"
" }\n"
" }\n"
+ "\n"
+ " # print join(\",\", @addrs), \" => \", join(\",\", @result), \"\\n\";\n"
" return @result;\n"
"}\n"
+ "\n"
+ "# Generate percent string for a number and a total\n"
"sub Percent {\n"
" my $num = shift;\n"
" my $tot = shift;\n"
@@ -1679,6 +2632,8 @@ const char* pprof_perl() {
" return ($num == 0) ? \"nan\" : (($num > 0) ? \"+inf\" : \"-inf\");\n"
" }\n"
"}\n"
+ "\n"
+ "# Generate pretty-printed form of number\n"
"sub Unparse {\n"
" my $num = shift;\n"
" if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {\n"
@@ -1692,11 +2647,13 @@ const char* pprof_perl() {
" }\n"
" }\n"
" } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {\n"
- " return sprintf(\"%.3f\", $num / 1e9);\n"
+ " return sprintf(\"%.3f\", $num / 1e9); # Convert nanoseconds to seconds\n"
" } else {\n"
" return sprintf(\"%d\", $num);\n"
" }\n"
"}\n"
+ "\n"
+ "# Alternate pretty-printed form: 0 maps to \".\"\n"
"sub UnparseAlt {\n"
" my $num = shift;\n"
" if ($num == 0) {\n"
@@ -1705,6 +2662,18 @@ const char* pprof_perl() {
" return Unparse($num);\n"
" }\n"
"}\n"
+ "\n"
+ "# Alternate pretty-printed form: 0 maps to \"\"\n"
+ "sub HtmlPrintNumber {\n"
+ " my $num = shift;\n"
+ " if ($num == 0) {\n"
+ " return \"\";\n"
+ " } else {\n"
+ " return Unparse($num);\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "# Return output units\n"
"sub Units {\n"
" if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {\n"
" if ($main::opt_inuse_objects || $main::opt_alloc_objects) {\n"
@@ -1722,6 +2691,12 @@ const char* pprof_perl() {
" return \"samples\";\n"
" }\n"
"}\n"
+ "\n"
+ "##### Profile manipulation code #####\n"
+ "\n"
+ "# Generate flattened profile:\n"
+ "# If count is charged to stack [a,b,c,d], in generated profile,\n"
+ "# it will be charged to [a]\n"
"sub FlatProfile {\n"
" my $profile = shift;\n"
" my $result = {};\n"
@@ -1734,6 +2709,10 @@ const char* pprof_perl() {
" }\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# Generate cumulative profile:\n"
+ "# If count is charged to stack [a,b,c,d], in generated profile,\n"
+ "# it will be charged to [a], [b], [c], [d]\n"
"sub CumulativeProfile {\n"
" my $profile = shift;\n"
" my $result = {};\n"
@@ -1746,8 +2725,12 @@ const char* pprof_perl() {
" }\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# If the second-youngest PC on the stack is always the same, returns\n"
+ "# that pc. Otherwise, returns undef.\n"
"sub IsSecondPcAlwaysTheSame {\n"
" my $profile = shift;\n"
+ "\n"
" my $second_pc = undef;\n"
" foreach my $k (keys(%{$profile})) {\n"
" my @addrs = split(/\\n/, $k);\n"
@@ -1764,39 +2747,134 @@ const char* pprof_perl() {
" }\n"
" return $second_pc;\n"
"}\n"
+ "\n"
+ "sub ExtractSymbolLocationInlineStack {\n"
+ " my $symbols = shift;\n"
+ " my $address = shift;\n"
+ " my $stack = shift;\n"
+ " # 'addr2line' outputs \"\?\?:0\" for unknown locations; we do the\n"
+ " # same to be consistent.\n"
+ " if (exists $symbols->{$address}) {\n"
+ " my @localinlinestack = @{$symbols->{$address}};\n"
+ " for (my $i = $#localinlinestack; $i > 0; $i-=3) {\n"
+ " my $file = $localinlinestack[$i-1];\n"
+ " my $fn = $localinlinestack[$i-2];\n"
+ " if ($file eq \"?\" || $file eq \":0\") {\n"
+ " $file = \"\?\?:0\";\n"
+ " }\n"
+ " my $suffix = \"[inline]\";\n"
+ " if ($i == 2) {\n"
+ " $suffix = \"\";\n"
+ " }\n"
+ " push (@$stack, $file.\":\".$fn.$suffix);\n"
+ " }\n"
+ " }\n"
+ " else {\n"
+ " push (@$stack, \"\?\?:0:unknown\");\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "sub ExtractSymbolNameInlineStack {\n"
+ " my $symbols = shift;\n"
+ " my $address = shift;\n"
+ "\n"
+ " my @stack = ();\n"
+ "\n"
+ " if (exists $symbols->{$address}) {\n"
+ " my @localinlinestack = @{$symbols->{$address}};\n"
+ " for (my $i = $#localinlinestack; $i > 0; $i-=3) {\n"
+ " my $file = $localinlinestack[$i-1];\n"
+ " my $fn = $localinlinestack[$i-0];\n"
+ "\n"
+ " if ($file eq \"?\" || $file eq \":0\") {\n"
+ " $file = \"\?\?:0\";\n"
+ " }\n"
+ " if ($fn eq '\?\?') {\n"
+ " # If we can't get the symbol name, at least use the file information.\n"
+ " $fn = $file;\n"
+ " }\n"
+ " my $suffix = \"[inline]\";\n"
+ " if ($i == 2) {\n"
+ " $suffix = \"\";\n"
+ " }\n"
+ " push (@stack, $fn.$suffix);\n"
+ " }\n"
+ " }\n"
+ " else {\n"
+ " # If we can't get a symbol name, at least fill in the address.\n"
+ " push (@stack, $address);\n"
+ " }\n"
+ "\n"
+ " return @stack;\n"
+ "}\n"
+ "\n"
"sub ExtractSymbolLocation {\n"
" my $symbols = shift;\n"
" my $address = shift;\n"
+ " # 'addr2line' outputs \"\?\?:0\" for unknown locations; we do the\n"
+ " # same to be consistent.\n"
" my $location = \"\?\?:0:unknown\";\n"
" if (exists $symbols->{$address}) {\n"
" my $file = $symbols->{$address}->[1];\n"
- " if ($file eq \"?\") {\n"
+ " if ($file eq \"?\" || $file eq \":0\") {\n"
" $file = \"\?\?:0\"\n"
" }\n"
" $location = $file . \":\" . $symbols->{$address}->[0];\n"
" }\n"
" return $location;\n"
"}\n"
+ "\n"
+ "# Extracts a graph of calls.\n"
"sub ExtractCalls {\n"
" my $symbols = shift;\n"
" my $profile = shift;\n"
" my $calls = {};\n"
" while( my ($stack_trace, $count) = each %$profile ) {\n"
" my @address = split(/\\n/, $stack_trace);\n"
- " my $destination = ExtractSymbolLocation($symbols, $address[0]);\n"
- " AddEntry($calls, $destination, $count);\n"
+ " my @stack = ();\n"
+ " ExtractSymbolLocationInlineStack($symbols, $address[0], \\@stack);\n"
" for (my $i = 1; $i <= $#address; $i++) {\n"
- " my $source = ExtractSymbolLocation($symbols, $address[$i]);\n"
- " my $call = \"$source -> $destination\";\n"
- " AddEntry($calls, $call, $count);\n"
- " $destination = $source;\n"
+ " ExtractSymbolLocationInlineStack($symbols, $address[$i], \\@stack);\n"
+ " }\n"
+ " AddEntry($calls, $stack[0], $count);\n"
+ " for (my $i = 1; $i < $#address; $i++) {\n"
+ " AddEntry($calls, \"$stack[$i] -> $stack[$i-1]\", $count);\n"
" }\n"
" }\n"
" return $calls;\n"
"}\n"
+ "\n"
+ "sub PrintStacksForText {\n"
+ " my $symbols = shift;\n"
+ " my $profile = shift;\n"
+ "\n"
+ " while (my ($stack_trace, $count) = each %$profile) {\n"
+ " my @address = split(/\\n/, $stack_trace);\n"
+ " for (my $i = 0; $i <= $#address; $i++) {\n"
+ " $address[$i] = sprintf(\"(%s) %s\", $address[$i], "
+ "ExtractSymbolLocation($symbols, $address[$i]));\n"
+ " }\n"
+ " printf(\"%-8d %s\\n\\n\", $count, join(\"\\n \", @address));\n"
+ " }\n"
+ "}\n"
+ "\n"
+ "sub PrintCollapsedStacks {\n"
+ " my $symbols = shift;\n"
+ " my $profile = shift;\n"
+ "\n"
+ " while (my ($stack_trace, $count) = each %$profile) {\n"
+ " my @address = split(/\\n/, $stack_trace);\n"
+ " my @names = reverse ( map { ExtractSymbolNameInlineStack($symbols, $_) } @address "
+ ");\n"
+ " printf(\"%s %d\\n\", join(\";\", @names), $count);\n"
+ " }\n"
+ "}\n"
+ "\n"
"sub RemoveUninterestingFrames {\n"
" my $symbols = shift;\n"
" my $profile = shift;\n"
+ "\n"
+ " # List of function names to skip\n"
" my %skip = ();\n"
" my $skip_regexp = 'NOMATCH';\n"
" if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {\n"
@@ -1825,7 +2903,7 @@ const char* pprof_perl() {
" 'tc_new_nothrow',\n"
" 'tc_newarray_nothrow',\n"
" 'do_malloc',\n"
- " '::do_malloc',\n"
+ " '::do_malloc', # new name -- got moved to an unnamed ns\n"
" '::do_malloc_or_cpp_alloc',\n"
" 'DoSampledAllocation',\n"
" 'simple_alloc::allocate',\n"
@@ -1836,21 +2914,44 @@ const char* pprof_perl() {
" '__builtin_vec_new',\n"
" 'operator new',\n"
" 'operator new[]',\n"
+ " # The entry to our memory-allocation routines on OS X\n"
+ " 'malloc_zone_malloc',\n"
+ " 'malloc_zone_calloc',\n"
+ " 'malloc_zone_valloc',\n"
+ " 'malloc_zone_realloc',\n"
+ " 'malloc_zone_memalign',\n"
+ " 'malloc_zone_free',\n"
+ " # These mark the beginning/end of our custom sections\n"
" '__start_google_malloc',\n"
" '__stop_google_malloc',\n"
" '__start_malloc_hook',\n"
" '__stop_malloc_hook') {\n"
" $skip{$name} = 1;\n"
- " $skip{\"_\" . $name} = 1;\n"
+ " $skip{\"_\" . $name} = 1; # Mach (OS X) adds a _ prefix to everything\n"
" }\n"
+ " # TODO: Remove TCMalloc once everything has been\n"
+ " # moved into the tcmalloc:: namespace and we have flushed\n"
+ " # old code out of the system.\n"
" $skip_regexp = \"TCMalloc|^tcmalloc::\";\n"
" } elsif ($main::profile_type eq 'contention') {\n"
- " foreach my $vname ('Mutex::Unlock', 'Mutex::UnlockSlow') {\n"
+ " foreach my $vname ('base::RecordLockProfileData',\n"
+ " 'base::SubmitMutexProfileData',\n"
+ " 'base::SubmitSpinLockProfileData',\n"
+ " 'Mutex::Unlock',\n"
+ " 'Mutex::UnlockSlow',\n"
+ " 'Mutex::ReaderUnlock',\n"
+ " 'MutexLock::~MutexLock',\n"
+ " 'SpinLock::Unlock',\n"
+ " 'SpinLock::SlowUnlock',\n"
+ " 'SpinLockHolder::~SpinLockHolder') {\n"
" $skip{$vname} = 1;\n"
" }\n"
- " } elsif ($main::profile_type eq 'cpu') {\n"
- " foreach my $name ('ProfileData::Add',\n"
- " 'ProfileData::prof_handler',\n"
+ " } elsif ($main::profile_type eq 'cpu' && !$main::opt_no_auto_signal_frames) {\n"
+ " # Drop signal handlers used for CPU profile collection\n"
+ " # TODO(dpeng): this should not be necessary; it's taken\n"
+ " # care of by the general 2nd-pc mechanism below.\n"
+ " foreach my $name ('ProfileData::Add', # historical\n"
+ " 'ProfileData::prof_handler', # historical\n"
" 'CpuProfiler::prof_handler',\n"
" '__FRAME_END__',\n"
" '__pthread_sighandler',\n"
@@ -1858,25 +2959,46 @@ const char* pprof_perl() {
" $skip{$name} = 1;\n"
" }\n"
" } else {\n"
+ " # Nothing skipped for unknown types\n"
" }\n"
+ "\n"
" if ($main::profile_type eq 'cpu') {\n"
+ " # If all the second-youngest program counters are the same,\n"
+ " # this STRONGLY suggests that it is an artifact of measurement,\n"
+ " # i.e., stack frames pushed by the CPU profiler signal handler.\n"
+ " # Hence, we delete them.\n"
+ " # (The topmost PC is read from the signal structure, not from\n"
+ " # the stack, so it does not get involved.)\n"
" while (my $second_pc = IsSecondPcAlwaysTheSame($profile)) {\n"
" my $result = {};\n"
" my $func = '';\n"
" if (exists($symbols->{$second_pc})) {\n"
" $second_pc = $symbols->{$second_pc}->[0];\n"
" }\n"
+ " if ($main::opt_no_auto_signal_frames) {\n"
+ " print STDERR \"All second stack frames are same: `$second_pc'.\\nMight be "
+ "stack trace capturing bug.\\n\";\n"
+ " last;\n"
+ " }\n"
" print STDERR \"Removing $second_pc from all stack traces.\\n\";\n"
" foreach my $k (keys(%{$profile})) {\n"
" my $count = $profile->{$k};\n"
" my @addrs = split(/\\n/, $k);\n"
+ " my $topaddr = POSIX::strtoul($addrs[0], 16);\n"
" splice @addrs, 1, 1;\n"
+ " if ($#addrs > 1) {\n"
+ " my $subtopaddr = POSIX::strtoul($addrs[1], 16);\n"
+ " if ($subtopaddr + 1 == $topaddr) {\n"
+ " splice @addrs, 1, 1;\n"
+ " }\n"
+ " }\n"
" my $reduced_path = join(\"\\n\", @addrs);\n"
" AddEntry($result, $reduced_path, $count);\n"
" }\n"
" $profile = $result;\n"
" }\n"
" }\n"
+ "\n"
" my $result = {};\n"
" foreach my $k (keys(%{$profile})) {\n"
" my $count = $profile->{$k};\n"
@@ -1896,17 +3018,23 @@ const char* pprof_perl() {
" }\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# Reduce profile to granularity given by user\n"
"sub ReduceProfile {\n"
" my $symbols = shift;\n"
" my $profile = shift;\n"
" my $result = {};\n"
+ " my $fullname_to_shortname_map = {};\n"
+ " FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);\n"
" foreach my $k (keys(%{$profile})) {\n"
" my $count = $profile->{$k};\n"
- " my @translated = TranslateStack($symbols, $k);\n"
+ " my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);\n"
" my @path = ();\n"
" my %seen = ();\n"
- " $seen{''} = 1;\n"
+ " $seen{''} = 1; # So that empty keys are skipped\n"
" foreach my $e (@translated) {\n"
+ " # To avoid double-counting due to recursion, skip a stack-trace\n"
+ " # entry if it has already been seen\n"
" if (!$seen{$e}) {\n"
" $seen{$e} = 1;\n"
" push(@path, $e);\n"
@@ -1917,6 +3045,8 @@ const char* pprof_perl() {
" }\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# Does the specified symbol array match the regexp?\n"
"sub SymbolMatches {\n"
" my $sym = shift;\n"
" my $re = shift;\n"
@@ -1929,6 +3059,8 @@ const char* pprof_perl() {
" }\n"
" return 0;\n"
"}\n"
+ "\n"
+ "# Focus only on paths involving specified regexps\n"
"sub FocusProfile {\n"
" my $symbols = shift;\n"
" my $profile = shift;\n"
@@ -1938,6 +3070,7 @@ const char* pprof_perl() {
" my $count = $profile->{$k};\n"
" my @addrs = split(/\\n/, $k);\n"
" foreach my $a (@addrs) {\n"
+ " # Reply if it matches either the address/shortname/fileline\n"
" if (($a =~ m/$focus/) || SymbolMatches($symbols->{$a}, $focus)) {\n"
" AddEntry($result, $k, $count);\n"
" last;\n"
@@ -1946,6 +3079,8 @@ const char* pprof_perl() {
" }\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# Focus only on paths not involving specified regexps\n"
"sub IgnoreProfile {\n"
" my $symbols = shift;\n"
" my $profile = shift;\n"
@@ -1956,6 +3091,7 @@ const char* pprof_perl() {
" my @addrs = split(/\\n/, $k);\n"
" my $matched = 0;\n"
" foreach my $a (@addrs) {\n"
+ " # Reply if it matches either the address/shortname/fileline\n"
" if (($a =~ m/$ignore/) || SymbolMatches($symbols->{$a}, $ignore)) {\n"
" $matched = 1;\n"
" last;\n"
@@ -1967,6 +3103,8 @@ const char* pprof_perl() {
" }\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# Get total count in profile\n"
"sub TotalProfile {\n"
" my $profile = shift;\n"
" my $result = 0;\n"
@@ -1975,23 +3113,31 @@ const char* pprof_perl() {
" }\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# Add A to B\n"
"sub AddProfile {\n"
" my $A = shift;\n"
" my $B = shift;\n"
+ "\n"
" my $R = {};\n"
+ " # add all keys in A\n"
" foreach my $k (keys(%{$A})) {\n"
" my $v = $A->{$k};\n"
" AddEntry($R, $k, $v);\n"
" }\n"
+ " # add all keys in B\n"
" foreach my $k (keys(%{$B})) {\n"
" my $v = $B->{$k};\n"
" AddEntry($R, $k, $v);\n"
" }\n"
" return $R;\n"
"}\n"
+ "\n"
+ "# Merges symbol maps\n"
"sub MergeSymbols {\n"
" my $A = shift;\n"
" my $B = shift;\n"
+ "\n"
" my $R = {};\n"
" foreach my $k (keys(%{$A})) {\n"
" $R->{$k} = $A->{$k};\n"
@@ -2003,21 +3149,30 @@ const char* pprof_perl() {
" }\n"
" return $R;\n"
"}\n"
+ "\n"
+ "\n"
+ "# Add A to B\n"
"sub AddPcs {\n"
" my $A = shift;\n"
" my $B = shift;\n"
+ "\n"
" my $R = {};\n"
+ " # add all keys in A\n"
" foreach my $k (keys(%{$A})) {\n"
" $R->{$k} = 1\n"
" }\n"
+ " # add all keys in B\n"
" foreach my $k (keys(%{$B})) {\n"
" $R->{$k} = 1\n"
" }\n"
" return $R;\n"
"}\n"
+ "\n"
+ "# Subtract B from A\n"
"sub SubtractProfile {\n"
" my $A = shift;\n"
" my $B = shift;\n"
+ "\n"
" my $R = {};\n"
" foreach my $k (keys(%{$A})) {\n"
" my $v = $A->{$k} - GetEntry($B, $k);\n"
@@ -2027,6 +3182,7 @@ const char* pprof_perl() {
" AddEntry($R, $k, $v);\n"
" }\n"
" if (!$main::opt_drop_negative) {\n"
+ " # Take care of when subtracted profile has more entries\n"
" foreach my $k (keys(%{$B})) {\n"
" if (!exists($A->{$k})) {\n"
" AddEntry($R, $k, 0 - $B->{$k});\n"
@@ -2035,6 +3191,8 @@ const char* pprof_perl() {
" }\n"
" return $R;\n"
"}\n"
+ "\n"
+ "# Get entry from profile; zero if not present\n"
"sub GetEntry {\n"
" my $profile = shift;\n"
" my $k = shift;\n"
@@ -2044,6 +3202,8 @@ const char* pprof_perl() {
" return 0;\n"
" }\n"
"}\n"
+ "\n"
+ "# Add entry to specified profile\n"
"sub AddEntry {\n"
" my $profile = shift;\n"
" my $k = shift;\n"
@@ -2053,12 +3213,16 @@ const char* pprof_perl() {
" }\n"
" $profile->{$k} += $n;\n"
"}\n"
+ "\n"
+ "# Add a stack of entries to specified profile, and add them to the $pcs\n"
+ "# list.\n"
"sub AddEntries {\n"
" my $profile = shift;\n"
" my $pcs = shift;\n"
" my $stack = shift;\n"
" my $count = shift;\n"
" my @k = ();\n"
+ "\n"
" foreach my $e (split(/\\s+/, $stack)) {\n"
" my $pc = HexExtend($e);\n"
" $pcs->{$pc} = 1;\n"
@@ -2066,15 +3230,20 @@ const char* pprof_perl() {
" }\n"
" AddEntry($profile, (join \"\\n\", @k), $count);\n"
"}\n"
+ "\n"
+ "##### Code to profile a server dynamically #####\n"
+ "\n"
"sub CheckSymbolPage {\n"
" my $url = SymbolPageURL();\n"
- " open(SYMBOL, \"$URL_FETCHER '$url' |\");\n"
+ " my $command = ShellEscape(@URL_FETCHER, $url);\n"
+ " open(SYMBOL, \"$command |\") or error($command);\n"
" my $line = <SYMBOL>;\n"
- " $line =~ s/\\r//g;\n"
+ " $line =~ s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" close(SYMBOL);\n"
" unless (defined($line)) {\n"
" error(\"$url doesn't exist\\n\");\n"
" }\n"
+ "\n"
" if ($line =~ /^num_symbols:\\s+(\\d+)$/) {\n"
" if ($1 == 0) {\n"
" error(\"Stripped binary. No symbols available.\\n\");\n"
@@ -2083,6 +3252,7 @@ const char* pprof_perl() {
" error(\"Failed to get the number of symbols from $url\\n\");\n"
" }\n"
"}\n"
+ "\n"
"sub IsProfileURL {\n"
" my $profile_name = shift;\n"
" if (-f $profile_name) {\n"
@@ -2091,44 +3261,59 @@ const char* pprof_perl() {
" }\n"
" return 1;\n"
"}\n"
+ "\n"
"sub ParseProfileURL {\n"
" my $profile_name = shift;\n"
+ "\n"
" if (!defined($profile_name) || $profile_name eq \"\") {\n"
" return ();\n"
" }\n"
+ "\n"
+ " # Split profile URL - matches all non-empty strings, so no test.\n"
" $profile_name =~ m,^(https?://)?([^/]+)(.*?)(/|$PROFILES)?$,;\n"
+ "\n"
" my $proto = $1 || \"http://\";\n"
" my $hostport = $2;\n"
" my $prefix = $3;\n"
" my $profile = $4 || \"/\";\n"
+ "\n"
" my $host = $hostport;\n"
" $host =~ s/:.*//;\n"
+ "\n"
" my $baseurl = \"$proto$hostport$prefix\";\n"
" return ($host, $baseurl, $profile);\n"
"}\n"
+ "\n"
+ "# We fetch symbols from the first profile argument.\n"
"sub SymbolPageURL {\n"
" my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);\n"
" return \"$baseURL$SYMBOL_PAGE\";\n"
"}\n"
+ "\n"
"sub FetchProgramName() {\n"
" my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);\n"
" my $url = \"$baseURL$PROGRAM_NAME_PAGE\";\n"
- " my $command_line = \"$URL_FETCHER '$url'\";\n"
+ " my $command_line = ShellEscape(@URL_FETCHER, $url);\n"
" open(CMDLINE, \"$command_line |\") or error($command_line);\n"
" my $cmdline = <CMDLINE>;\n"
- " $cmdline =~ s/\\r//g;\n"
+ " $cmdline =~ s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" close(CMDLINE);\n"
" error(\"Failed to get program name from $url\\n\") unless defined($cmdline);\n"
- " $cmdline =~ s/\\x00.+//;\n"
- " $cmdline =~ s!\\n!!g;\n"
+ " $cmdline =~ s/\\x00.+//; # Remove argv[1] and latters.\n"
+ " $cmdline =~ s!\\n!!g; # Remove LFs.\n"
" return $cmdline;\n"
"}\n"
+ "\n"
+ "# Gee, curl's -L (--location) option isn't reliable at least\n"
+ "# with its 7.12.3 version. Curl will forget to post data if\n"
+ "# there is a redirection. This function is a workaround for\n"
+ "# curl. Redirection happens on borg hosts.\n"
"sub ResolveRedirectionForCurl {\n"
" my $url = shift;\n"
- " my $command_line = \"$URL_FETCHER --head '$url'\";\n"
+ " my $command_line = ShellEscape(@URL_FETCHER, \"--head\", $url);\n"
" open(CMDLINE, \"$command_line |\") or error($command_line);\n"
" while (<CMDLINE>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" if (/^Location: (.*)/) {\n"
" $url = $1;\n"
" }\n"
@@ -2136,23 +3321,31 @@ const char* pprof_perl() {
" close(CMDLINE);\n"
" return $url;\n"
"}\n"
+ "\n"
+ "# Add a timeout flat to URL_FETCHER. Returns a new list.\n"
"sub AddFetchTimeout {\n"
- " my $fetcher = shift;\n"
" my $timeout = shift;\n"
+ " my @fetcher = @_;\n"
" if (defined($timeout)) {\n"
- " if ($fetcher =~ m/\\bcurl -s/) {\n"
- " $fetcher .= sprintf(\" --max-time %d\", $timeout);\n"
- " } elsif ($fetcher =~ m/\\brpcget\\b/) {\n"
- " $fetcher .= sprintf(\" --deadline=%d\", $timeout);\n"
+ " if (join(\" \", @fetcher) =~ m/\\bcurl -s/) {\n"
+ " push(@fetcher, \"--max-time\", sprintf(\"%d\", $timeout));\n"
+ " } elsif (join(\" \", @fetcher) =~ m/\\brpcget\\b/) {\n"
+ " push(@fetcher, sprintf(\"--deadline=%d\", $timeout));\n"
" }\n"
" }\n"
- " return $fetcher;\n"
+ " return @fetcher;\n"
"}\n"
+ "\n"
+ "# Reads a symbol map from the file handle name given as $1, returning\n"
+ "# the resulting symbol map. Also processes variables relating to symbols.\n"
+ "# Currently, the only variable processed is 'binary=<value>' which updates\n"
+ "# $main::prog to have the correct program name.\n"
"sub ReadSymbols {\n"
" my $in = shift;\n"
" my $map = {};\n"
" while (<$in>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
+ " # Removes all the leading zeroes from the symbols, see comment below.\n"
" if (m/^0x0*([0-9a-f]+)\\s+(.+)/) {\n"
" $map->{$1} = $2;\n"
" } elsif (m/^---/) {\n"
@@ -2177,39 +3370,62 @@ const char* pprof_perl() {
" }\n"
" return $map;\n"
"}\n"
+ "\n"
+ "# Fetches and processes symbols to prepare them for use in the profile output\n"
+ "# code. If the optional 'symbol_map' arg is not given, fetches symbols from\n"
+ "# $SYMBOL_PAGE for all PC values found in profile. Otherwise, the raw symbols\n"
+ "# are assumed to have already been fetched into 'symbol_map' and are simply\n"
+ "# extracted and processed.\n"
"sub FetchSymbols {\n"
" my $pcset = shift;\n"
" my $symbol_map = shift;\n"
+ "\n"
" my %seen = ();\n"
- " my @pcs = grep { !$seen{$_}++ } keys(%$pcset);\n"
+ " my @pcs = grep { !$seen{$_}++ } keys(%$pcset); # uniq\n"
+ "\n"
" if (!defined($symbol_map)) {\n"
" my $post_data = join(\"+\", sort((map {\"0x\" . \"$_\"} @pcs)));\n"
+ "\n"
" open(POSTFILE, \">$main::tmpfile_sym\");\n"
" print POSTFILE $post_data;\n"
" close(POSTFILE);\n"
+ "\n"
" my $url = SymbolPageURL();\n"
+ "\n"
" my $command_line;\n"
- " if ($URL_FETCHER =~ m/\\bcurl -s/) {\n"
+ " if (join(\" \", @URL_FETCHER) =~ m/\\bcurl -s/) {\n"
" $url = ResolveRedirectionForCurl($url);\n"
- " $command_line = \"$URL_FETCHER -d '\\@$main::tmpfile_sym' '$url'\";\n"
+ " $command_line = ShellEscape(@URL_FETCHER, \"-d\", \"\\@$main::tmpfile_sym\",\n"
+ " $url);\n"
" } else {\n"
- " $command_line = \"$URL_FETCHER --post '$url' < '$main::tmpfile_sym'\";\n"
+ " $command_line = (ShellEscape(@URL_FETCHER, \"--post\", $url)\n"
+ " . \" < \" . ShellEscape($main::tmpfile_sym));\n"
" }\n"
- " my $cppfilt = $obj_tool_map{\"c++filt\"};\n"
- " open(SYMBOL, \"$command_line | $cppfilt |\") or error($command_line);\n"
+ " # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols.\n"
+ " my $escaped_cppfilt = ShellEscape($obj_tool_map{\"c++filt\"});\n"
+ " open(SYMBOL, \"$command_line | $escaped_cppfilt |\") or error($command_line);\n"
" $symbol_map = ReadSymbols(*SYMBOL{IO});\n"
" close(SYMBOL);\n"
" }\n"
+ "\n"
" my $symbols = {};\n"
" foreach my $pc (@pcs) {\n"
" my $fullname;\n"
+ " # For 64 bits binaries, symbols are extracted with 8 leading zeroes.\n"
+ " # Then /symbol reads the long symbols in as uint64, and outputs\n"
+ " # the result with a \"0x%08llx\" format which get rid of the zeroes.\n"
+ " # By removing all the leading zeroes in both $pc and the symbols from\n"
+ " # /symbol, the symbols match and are retrievable from the map.\n"
" my $shortpc = $pc;\n"
" $shortpc =~ s/^0*//;\n"
+ " # Each line may have a list of names, which includes the function\n"
+ " # and also other functions it has inlined. They are separated (in\n"
+ " # PrintSymbolizedProfile), by --, which is illegal in function names.\n"
" my $fullnames;\n"
" if (defined($symbol_map->{$shortpc})) {\n"
" $fullnames = $symbol_map->{$shortpc};\n"
" } else {\n"
- " $fullnames = \"0x\" . $pc;\n"
+ " $fullnames = \"0x\" . $pc; # Just use addresses\n"
" }\n"
" my $sym = [];\n"
" $symbols->{$pc} = $sym;\n"
@@ -2220,11 +3436,13 @@ const char* pprof_perl() {
" }\n"
" return $symbols;\n"
"}\n"
+ "\n"
"sub BaseName {\n"
" my $file_name = shift;\n"
- " $file_name =~ s!^.*/!!;\n"
+ " $file_name =~ s!^.*/!!; # Remove directory name\n"
" return $file_name;\n"
"}\n"
+ "\n"
"sub MakeProfileBaseName {\n"
" my ($binary_name, $profile_name) = @_;\n"
" my ($host, $baseURL, $path) = ParseProfileURL($profile_name);\n"
@@ -2232,19 +3450,24 @@ const char* pprof_perl() {
" return sprintf(\"%s.%s.%s\",\n"
" $binary_shortname, $main::op_time, $host);\n"
"}\n"
+ "\n"
"sub FetchDynamicProfile {\n"
" my $binary_name = shift;\n"
" my $profile_name = shift;\n"
" my $fetch_name_only = shift;\n"
" my $encourage_patience = shift;\n"
+ "\n"
" if (!IsProfileURL($profile_name)) {\n"
" return $profile_name;\n"
" } else {\n"
" my ($host, $baseURL, $path) = ParseProfileURL($profile_name);\n"
" if ($path eq \"\" || $path eq \"/\") {\n"
+ " # Missing type specifier defaults to cpu-profile\n"
" $path = $PROFILE_PAGE;\n"
" }\n"
+ "\n"
" my $profile_file = MakeProfileBaseName($binary_name, $profile_name);\n"
+ "\n"
" my $url = \"$baseURL$path\";\n"
" my $fetch_timeout = undef;\n"
" if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE/) {\n"
@@ -2256,10 +3479,13 @@ const char* pprof_perl() {
" $url .= sprintf(\"seconds=%d\", $main::opt_seconds);\n"
" $fetch_timeout = $main::opt_seconds * 1.01 + 60;\n"
" } else {\n"
+ " # For non-CPU profiles, we add a type-extension to\n"
+ " # the target profile file name.\n"
" my $suffix = $path;\n"
" $suffix =~ s,/,.,g;\n"
" $profile_file .= $suffix;\n"
" }\n"
+ "\n"
" my $profile_dir = $ENV{\"PPROF_TMPDIR\"} || ($ENV{HOME} . \"/pprof\");\n"
" if (! -d $profile_dir) {\n"
" mkdir($profile_dir)\n"
@@ -2267,48 +3493,63 @@ const char* pprof_perl() {
" }\n"
" my $tmp_profile = \"$profile_dir/.tmp.$profile_file\";\n"
" my $real_profile = \"$profile_dir/$profile_file\";\n"
+ "\n"
" if ($fetch_name_only > 0) {\n"
" return $real_profile;\n"
" }\n"
- " my $fetcher = AddFetchTimeout($URL_FETCHER, $fetch_timeout);\n"
- " my $cmd = \"$fetcher '$url' > '$tmp_profile'\";\n"
- " if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE/){\n"
- " print STDERR \"Gathering CPU profile from $url for $main::opt_seconds seconds to\\n ${real_profile}\\n\";\n"
+ "\n"
+ " my @fetcher = AddFetchTimeout($fetch_timeout, @URL_FETCHER);\n"
+ " my $cmd = ShellEscape(@fetcher, $url) . \" > \" . ShellEscape($tmp_profile);\n"
+ " if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE|$CENSUSPROFILE_PAGE/){\n"
+ " print STDERR \"Gathering CPU profile from $url for $main::opt_seconds seconds "
+ "to\\n ${real_profile}\\n\";\n"
" if ($encourage_patience) {\n"
" print STDERR \"Be patient...\\n\";\n"
" }\n"
" } else {\n"
" print STDERR \"Fetching $path profile from $url to\\n ${real_profile}\\n\";\n"
" }\n"
+ "\n"
" (system($cmd) == 0) || error(\"Failed to get profile: $cmd: $!\\n\");\n"
- " (system(\"mv $tmp_profile $real_profile\") == 0) || error(\"Unable to rename profile\\n\");\n"
+ " (system(\"mv\", $tmp_profile, $real_profile) == 0) || error(\"Unable to rename "
+ "profile\\n\");\n"
" print STDERR \"Wrote profile to $real_profile\\n\";\n"
" $main::collected_profile = $real_profile;\n"
" return $main::collected_profile;\n"
" }\n"
"}\n"
+ "\n"
+ "# Collect profiles in parallel\n"
"sub FetchDynamicProfiles {\n"
" my $items = scalar(@main::pfile_args);\n"
" my $levels = log($items) / log(2);\n"
+ "\n"
" if ($items == 1) {\n"
- " $main::profile_files[0] = FetchDynamicProfile($main::prog, $main::pfile_args[0], 0, 1);\n"
+ " $main::profile_files[0] = FetchDynamicProfile($main::prog, $main::pfile_args[0], "
+ "0, 1);\n"
" } else {\n"
+ " # math rounding issues\n"
" if ((2 ** $levels) < $items) {\n"
" $levels++;\n"
" }\n"
" my $count = scalar(@main::pfile_args);\n"
" for (my $i = 0; $i < $count; $i++) {\n"
- " $main::profile_files[$i] = FetchDynamicProfile($main::prog, $main::pfile_args[$i], 1, 0);\n"
+ " $main::profile_files[$i] = FetchDynamicProfile($main::prog, "
+ "$main::pfile_args[$i], 1, 0);\n"
" }\n"
" print STDERR \"Fetching $count profiles, Be patient...\\n\";\n"
" FetchDynamicProfilesRecurse($levels, 0, 0);\n"
" $main::collected_profile = join(\" \\\\\\n \", @main::profile_files);\n"
" }\n"
"}\n"
+ "\n"
+ "# Recursively fork a process to get enough processes\n"
+ "# collecting profiles\n"
"sub FetchDynamicProfilesRecurse {\n"
" my $maxlevel = shift;\n"
" my $level = shift;\n"
" my $position = shift;\n"
+ "\n"
" if (my $pid = fork()) {\n"
" $position = 0 | ($position << 1);\n"
" TryCollectProfile($maxlevel, $level, $position);\n"
@@ -2320,10 +3561,13 @@ const char* pprof_perl() {
" exit(0);\n"
" }\n"
"}\n"
+ "\n"
+ "# Collect a single profile\n"
"sub TryCollectProfile {\n"
" my $maxlevel = shift;\n"
" my $level = shift;\n"
" my $position = shift;\n"
+ "\n"
" if ($level >= ($maxlevel - 1)) {\n"
" if ($position < scalar(@main::pfile_args)) {\n"
" FetchDynamicProfile($main::prog, $main::pfile_args[$position], 0, 0);\n"
@@ -2332,184 +3576,287 @@ const char* pprof_perl() {
" FetchDynamicProfilesRecurse($maxlevel, $level+1, $position);\n"
" }\n"
"}\n"
+ "\n"
+ "##### Parsing code #####\n"
+ "\n"
+ "# Provide a small streaming-read module to handle very large\n"
+ "# cpu-profile files. Stream in chunks along a sliding window.\n"
+ "# Provides an interface to get one 'slot', correctly handling\n"
+ "# endian-ness differences. A slot is one 32-bit or 64-bit word\n"
+ "# (depending on the input profile). We tell endianness and bit-size\n"
+ "# for the profile by looking at the first 8 bytes: in cpu profiles,\n"
+ "# the second slot is always 3 (we'll accept anything that's not 0).\n"
"BEGIN {\n"
" package CpuProfileStream;\n"
+ "\n"
" sub new {\n"
" my ($class, $file, $fname) = @_;\n"
" my $self = { file => $file,\n"
" base => 0,\n"
- " stride => 512 * 1024,\n"
+ " stride => 512 * 1024, # must be a multiple of bitsize/8\n"
" slots => [],\n"
- " unpack_code => \"\",\n"
- " perl_is_64bit => 1,\n"
+ " unpack_code => \"\", # N for big-endian, V for little\n"
+ " perl_is_64bit => 1, # matters if profile is 64-bit\n"
" };\n"
" bless $self, $class;\n"
+ " # Let unittests adjust the stride\n"
" if ($main::opt_test_stride > 0) {\n"
" $self->{stride} = $main::opt_test_stride;\n"
" }\n"
+ " # Read the first two slots to figure out bitsize and endianness.\n"
" my $slots = $self->{slots};\n"
" my $str;\n"
" read($self->{file}, $str, 8);\n"
+ " # Set the global $address_length based on what we see here.\n"
+ " # 8 is 32-bit (8 hexadecimal chars); 16 is 64-bit (16 hexadecimal chars).\n"
" $address_length = ($str eq (chr(0)x8)) ? 16 : 8;\n"
" if ($address_length == 8) {\n"
" if (substr($str, 6, 2) eq chr(0)x2) {\n"
- " $self->{unpack_code} = 'V';\n"
+ " $self->{unpack_code} = 'V'; # Little-endian.\n"
" } elsif (substr($str, 4, 2) eq chr(0)x2) {\n"
- " $self->{unpack_code} = 'N';\n"
+ " $self->{unpack_code} = 'N'; # Big-endian\n"
" } else {\n"
" ::error(\"$fname: header size >= 2**16\\n\");\n"
" }\n"
" @$slots = unpack($self->{unpack_code} . \"*\", $str);\n"
" } else {\n"
+ " # If we're a 64-bit profile, check if we're a 64-bit-capable\n"
+ " # perl. Otherwise, each slot will be represented as a float\n"
+ " # instead of an int64, losing precision and making all the\n"
+ " # 64-bit addresses wrong. We won't complain yet, but will\n"
+ " # later if we ever see a value that doesn't fit in 32 bits.\n"
" my $has_q = 0;\n"
" eval { $has_q = pack(\"Q\", \"1\") ? 1 : 1; };\n"
" if (!$has_q) {\n"
- " $self->{perl_is_64bit} = 0;\n"
+ " $self->{perl_is_64bit} = 0;\n"
" }\n"
" read($self->{file}, $str, 8);\n"
" if (substr($str, 4, 4) eq chr(0)x4) {\n"
- " $self->{unpack_code} = 'V';\n"
+ " # We'd love to use 'Q', but it's a) not universal, b) not endian-proof.\n"
+ " $self->{unpack_code} = 'V'; # Little-endian.\n"
" } elsif (substr($str, 0, 4) eq chr(0)x4) {\n"
- " $self->{unpack_code} = 'N';\n"
+ " $self->{unpack_code} = 'N'; # Big-endian\n"
" } else {\n"
" ::error(\"$fname: header size >= 2**32\\n\");\n"
" }\n"
" my @pair = unpack($self->{unpack_code} . \"*\", $str);\n"
+ " # Since we know one of the pair is 0, it's fine to just add them.\n"
" @$slots = (0, $pair[0] + $pair[1]);\n"
" }\n"
" return $self;\n"
" }\n"
+ "\n"
+ " # Load more data when we access slots->get(X) which is not yet in memory.\n"
" sub overflow {\n"
" my ($self) = @_;\n"
" my $slots = $self->{slots};\n"
- " $self->{base} += $#$slots + 1;\n"
+ " $self->{base} += $#$slots + 1; # skip over data we're replacing\n"
" my $str;\n"
" read($self->{file}, $str, $self->{stride});\n"
- " if ($address_length == 8) {\n"
+ " if ($address_length == 8) { # the 32-bit case\n"
+ " # This is the easy case: unpack provides 32-bit unpacking primitives.\n"
" @$slots = unpack($self->{unpack_code} . \"*\", $str);\n"
" } else {\n"
+ " # We need to unpack 32 bits at a time and combine.\n"
" my @b32_values = unpack($self->{unpack_code} . \"*\", $str);\n"
" my @b64_values = ();\n"
" for (my $i = 0; $i < $#b32_values; $i += 2) {\n"
- " my ($lo, $hi) = ($b32_values[$i], $b32_values[$i+1]);\n"
- " if ($self->{unpack_code} eq 'N') {\n"
- " ($lo, $hi) = ($hi, $lo);\n"
- " }\n"
- " my $value = $lo + $hi * (2**32);\n"
- " if (!$self->{perl_is_64bit} &&\n"
- " (($value % (2**32)) != $lo || int($value / (2**32)) != $hi)) {\n"
- " ::error(\"Need a 64-bit perl to process this 64-bit profile.\\n\");\n"
- " }\n"
- " push(@b64_values, $value);\n"
+ " # TODO(csilvers): if this is a 32-bit perl, the math below\n"
+ " # could end up in a too-large int, which perl will promote\n"
+ " # to a double, losing necessary precision. Deal with that.\n"
+ " # Right now, we just die.\n"
+ " my ($lo, $hi) = ($b32_values[$i], $b32_values[$i+1]);\n"
+ " if ($self->{unpack_code} eq 'N') { # big-endian\n"
+ " ($lo, $hi) = ($hi, $lo);\n"
+ " }\n"
+ " my $value = $lo + $hi * (2**32);\n"
+ " if (!$self->{perl_is_64bit} && # check value is exactly represented\n"
+ " (($value % (2**32)) != $lo || int($value / (2**32)) != $hi)) {\n"
+ " ::error(\"Need a 64-bit perl to process this 64-bit profile.\\n\");\n"
+ " }\n"
+ " push(@b64_values, $value);\n"
" }\n"
" @$slots = @b64_values;\n"
" }\n"
" }\n"
+ "\n"
+ " # Access the i-th long in the file (logically), or -1 at EOF.\n"
" sub get {\n"
" my ($self, $idx) = @_;\n"
" my $slots = $self->{slots};\n"
" while ($#$slots >= 0) {\n"
" if ($idx < $self->{base}) {\n"
+ " # The only time we expect a reference to $slots[$i - something]\n"
+ " # after referencing $slots[$i] is reading the very first header.\n"
+ " # Since $stride > |header|, that shouldn't cause any lookback\n"
+ " # errors. And everything after the header is sequential.\n"
" print STDERR \"Unexpected look-back reading CPU profile\";\n"
- " return -1;\n"
+ " return -1; # shrug, don't know what better to return\n"
" } elsif ($idx > $self->{base} + $#$slots) {\n"
" $self->overflow();\n"
" } else {\n"
" return $slots->[$idx - $self->{base}];\n"
" }\n"
" }\n"
- " return -1;\n"
+ " # If we get here, $slots is [], which means we've reached EOF\n"
+ " return -1; # unique since slots is supposed to hold unsigned numbers\n"
" }\n"
"}\n"
- "sub ReadProfileLine {\n"
+ "\n"
+ "# Reads the top, 'header' section of a profile, and returns the last\n"
+ "# line of the header, commonly called a 'header line'. The header\n"
+ "# section of a profile consists of zero or more 'command' lines that\n"
+ "# are instructions to pprof, which pprof executes when reading the\n"
+ "# header. All 'command' lines start with a %. After the command\n"
+ "# lines is the 'header line', which is a profile-specific line that\n"
+ "# indicates what type of profile it is, and perhaps other global\n"
+ "# information about the profile. For instance, here's a header line\n"
+ "# for a heap profile:\n"
+ "# heap profile: 53: 38236 [ 5525: 1284029] @ heapprofile\n"
+ "# For historical reasons, the CPU profile does not contain a text-\n"
+ "# readable header line. If the profile looks like a CPU profile,\n"
+ "# this function returns \"\". If no header line could be found, this\n"
+ "# function returns undef.\n"
+ "#\n"
+ "# The following commands are recognized:\n"
+ "# %warn -- emit the rest of this line to stderr, prefixed by 'WARNING:'\n"
+ "#\n"
+ "# The input file should be in binmode.\n"
+ "sub ReadProfileHeader {\n"
" local *PROFILE = shift;\n"
" my $firstchar = \"\";\n"
" my $line = \"\";\n"
" read(PROFILE, $firstchar, 1);\n"
- " seek(PROFILE, -1, 1);\n"
- " if ($firstchar eq \"\\0\") {\n"
+ " seek(PROFILE, -1, 1); # unread the firstchar\n"
+ " if ($firstchar !~ /[[:print:]]/) { # is not a text character\n"
" return \"\";\n"
" }\n"
- " $line = <PROFILE>;\n"
- " if (defined($line)) {\n"
- " $line =~ s/\\r//g;\n"
+ " while (defined($line = <PROFILE>)) {\n"
+ " $line =~ s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
+ " if ($line =~ /^%warn\\s+(.*)/) { # 'warn' command\n"
+ " # Note this matches both '%warn blah\\n' and '%warn\\n'.\n"
+ " print STDERR \"WARNING: $1\\n\"; # print the rest of the line\n"
+ " } elsif ($line =~ /^%/) {\n"
+ " print STDERR \"Ignoring unknown command from profile header: $line\";\n"
+ " } else {\n"
+ " # End of commands, must be the header line.\n"
+ " return $line;\n"
+ " }\n"
" }\n"
- " return $line;\n"
+ " return undef; # got to EOF without seeing a header line\n"
"}\n"
+ "\n"
"sub IsSymbolizedProfileFile {\n"
" my $file_name = shift;\n"
" if (!(-e $file_name) || !(-r $file_name)) {\n"
" return 0;\n"
" }\n"
+ " # Check if the file contains a symbol-section marker.\n"
" open(TFILE, \"<$file_name\");\n"
" binmode TFILE;\n"
- " my $firstline = ReadProfileLine(*TFILE);\n"
+ " my $firstline = ReadProfileHeader(*TFILE);\n"
" close(TFILE);\n"
" if (!$firstline) {\n"
" return 0;\n"
" }\n"
- " $SYMBOL_PAGE =~ m,[^/]+$,;\n"
+ " $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash\n"
" my $symbol_marker = $&;\n"
" return $firstline =~ /^--- *$symbol_marker/;\n"
"}\n"
+ "\n"
+ "# Parse profile generated by common/profiler.cc and return a reference\n"
+ "# to a map:\n"
+ "# $result->{version} Version number of profile file\n"
+ "# $result->{period} Sampling period (in microseconds)\n"
+ "# $result->{profile} Profile object\n"
+ "# $result->{map} Memory map info from profile\n"
+ "# $result->{pcs} Hash of all PC values seen, key is hex address\n"
"sub ReadProfile {\n"
" my $prog = shift;\n"
" my $fname = shift;\n"
- " if (IsSymbolizedProfileFile($fname) && !$main::use_symbolized_profile) {\n"
- " usage(\"Symbolized profile '$fname' cannot be used with a binary arg. \" .\n"
- " \"Try again without passing '$prog'.\");\n"
- " }\n"
- " $main::profile_type = '';\n"
- " $CONTENTION_PAGE =~ m,[^/]+$,;\n"
+ " my $result; # return value\n"
+ "\n"
+ " $CONTENTION_PAGE =~ m,[^/]+$,; # matches everything after the last slash\n"
" my $contention_marker = $&;\n"
- " $GROWTH_PAGE =~ m,[^/]+$,;\n"
+ " $GROWTH_PAGE =~ m,[^/]+$,; # matches everything after the last slash\n"
" my $growth_marker = $&;\n"
- " $SYMBOL_PAGE =~ m,[^/]+$,;\n"
+ " $SYMBOL_PAGE =~ m,[^/]+$,; # matches everything after the last slash\n"
" my $symbol_marker = $&;\n"
- " $PROFILE_PAGE =~ m,[^/]+$,;\n"
+ " $PROFILE_PAGE =~ m,[^/]+$,; # matches everything after the last slash\n"
" my $profile_marker = $&;\n"
+ "\n"
+ " # Look at first line to see if it is a heap or a CPU profile.\n"
+ " # CPU profile may start with no header at all, and just binary data\n"
+ " # (starting with \\0\\0\\0\\0) -- in that case, don't try to read the\n"
+ " # whole firstline, since it may be gigabytes(!) of data.\n"
" open(PROFILE, \"<$fname\") || error(\"$fname: $!\\n\");\n"
- " binmode PROFILE;\n"
- " my $header = ReadProfileLine(*PROFILE);\n"
- " if (!defined($header)) {\n"
+ " binmode PROFILE; # New perls do UTF-8 processing\n"
+ " my $header = ReadProfileHeader(*PROFILE);\n"
+ " if (!defined($header)) { # means \"at EOF\"\n"
" error(\"Profile is empty.\\n\");\n"
" }\n"
+ "\n"
" my $symbols;\n"
" if ($header =~ m/^--- *$symbol_marker/o) {\n"
+ " # Verify that the user asked for a symbolized profile\n"
+ " if (!$main::use_symbolized_profile) {\n"
+ " # we have both a binary and symbolized profiles, abort\n"
+ " error(\"FATAL ERROR: Symbolized profile\\n $fname\\ncannot be used with \" .\n"
+ " \"a binary arg. Try again without passing\\n $prog\\n\");\n"
+ " }\n"
+ " # Read the symbol section of the symbolized profile file.\n"
" $symbols = ReadSymbols(*PROFILE{IO});\n"
- " $header = ReadProfileLine(*PROFILE) || \"\";\n"
+ " # Read the next line to get the header for the remaining profile.\n"
+ " $header = ReadProfileHeader(*PROFILE) || \"\";\n"
" }\n"
- " my $result;\n"
+ "\n"
+ " $main::profile_type = '';\n"
" if ($header =~ m/^heap profile:.*$growth_marker/o) {\n"
" $main::profile_type = 'growth';\n"
- " $result = ReadHeapProfile($prog, $fname, $header);\n"
+ " $result = ReadHeapProfile($prog, *PROFILE, $header);\n"
" } elsif ($header =~ m/^heap profile:/) {\n"
" $main::profile_type = 'heap';\n"
- " $result = ReadHeapProfile($prog, $fname, $header);\n"
+ " $result = ReadHeapProfile($prog, *PROFILE, $header);\n"
" } elsif ($header =~ m/^--- *$contention_marker/o) {\n"
" $main::profile_type = 'contention';\n"
- " $result = ReadSynchProfile($prog, $fname);\n"
+ " $result = ReadSynchProfile($prog, *PROFILE);\n"
" } elsif ($header =~ m/^--- *Stacks:/) {\n"
" print STDERR\n"
" \"Old format contention profile: mistakenly reports \" .\n"
" \"condition variable signals as lock contentions.\\n\";\n"
" $main::profile_type = 'contention';\n"
- " $result = ReadSynchProfile($prog, $fname);\n"
+ " $result = ReadSynchProfile($prog, *PROFILE);\n"
" } elsif ($header =~ m/^--- *$profile_marker/) {\n"
+ " # the binary cpu profile data starts immediately after this line\n"
" $main::profile_type = 'cpu';\n"
- " $result = ReadCPUProfile($prog, $fname);\n"
+ " $result = ReadCPUProfile($prog, $fname, *PROFILE);\n"
" } else {\n"
" if (defined($symbols)) {\n"
+ " # a symbolized profile contains a format we don't recognize, bail out\n"
" error(\"$fname: Cannot recognize profile section after symbols.\\n\");\n"
" }\n"
+ " # no ascii header present -- must be a CPU profile\n"
" $main::profile_type = 'cpu';\n"
- " $result = ReadCPUProfile($prog, $fname);\n"
+ " $result = ReadCPUProfile($prog, $fname, *PROFILE);\n"
" }\n"
+ "\n"
+ " close(PROFILE);\n"
+ "\n"
+ " # if we got symbols along with the profile, return those as well\n"
" if (defined($symbols)) {\n"
" $result->{symbols} = $symbols;\n"
" }\n"
+ "\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# Subtract one from caller pc so we map back to call instr.\n"
+ "# However, don't do this if we're reading a symbolized profile\n"
+ "# file, in which case the subtract-one was done when the file\n"
+ "# was written.\n"
+ "#\n"
+ "# We apply the same logic to all readers, though ReadCPUProfile uses an\n"
+ "# independent implementation.\n"
"sub FixCallerAddresses {\n"
" my $stack = shift;\n"
" if ($main::use_symbolized_profile) {\n"
@@ -2529,39 +3876,62 @@ const char* pprof_perl() {
" return join $delimiter, @fixedaddrs;\n"
" }\n"
"}\n"
+ "\n"
+ "# CPU profile reader\n"
"sub ReadCPUProfile {\n"
" my $prog = shift;\n"
- " my $fname = shift;\n"
+ " my $fname = shift; # just used for logging\n"
+ " local *PROFILE = shift;\n"
" my $version;\n"
" my $period;\n"
" my $i;\n"
" my $profile = {};\n"
" my $pcs = {};\n"
+ "\n"
+ " # Parse string into array of slots.\n"
" my $slots = CpuProfileStream->new(*PROFILE, $fname);\n"
+ "\n"
+ " # Read header. The current header version is a 5-element structure\n"
+ " # containing:\n"
+ " # 0: header count (always 0)\n"
+ " # 1: header \"words\" (after this one: 3)\n"
+ " # 2: format version (0)\n"
+ " # 3: sampling period (usec)\n"
+ " # 4: unused padding (always 0)\n"
" if ($slots->get(0) != 0 ) {\n"
" error(\"$fname: not a profile file, or old format profile file\\n\");\n"
" }\n"
" $i = 2 + $slots->get(1);\n"
" $version = $slots->get(2);\n"
" $period = $slots->get(3);\n"
+ " # Do some sanity checking on these header values.\n"
" if ($version > (2**32) || $period > (2**32) || $i > (2**32) || $i < 5) {\n"
" error(\"$fname: not a profile file, or corrupted profile file\\n\");\n"
" }\n"
+ "\n"
+ " # Parse profile\n"
" while ($slots->get($i) != -1) {\n"
" my $n = $slots->get($i++);\n"
" my $d = $slots->get($i++);\n"
- " if ($d > (2**16)) {\n"
+ " if ($d > (2**16)) { # TODO(csilvers): what's a reasonable max-stack-depth?\n"
" my $addr = sprintf(\"0%o\", $i * ($address_length == 8 ? 4 : 8));\n"
" print STDERR \"At index $i (address $addr):\\n\";\n"
" error(\"$fname: stack trace depth >= 2**32\\n\");\n"
" }\n"
" if ($slots->get($i) == 0) {\n"
+ " # End of profile data marker\n"
" $i += $d;\n"
" last;\n"
" }\n"
+ "\n"
+ " # Make key out of the stack entries\n"
" my @k = ();\n"
" for (my $j = 0; $j < $d; $j++) {\n"
" my $pc = $slots->get($i+$j);\n"
+ " # Subtract one from caller pc so we map back to call instr.\n"
+ " # However, don't do this if we're reading a symbolized profile\n"
+ " # file, in which case the subtract-one was done when the file\n"
+ " # was written.\n"
" if ($j > 0 && !$main::use_symbolized_profile) {\n"
" $pc--;\n"
" }\n"
@@ -2569,25 +3939,31 @@ const char* pprof_perl() {
" $pcs->{$pc} = 1;\n"
" push @k, $pc;\n"
" }\n"
+ "\n"
" AddEntry($profile, (join \"\\n\", @k), $n);\n"
" $i += $d;\n"
" }\n"
+ "\n"
+ " # Parse map\n"
" my $map = '';\n"
- " seek(PROFILE, $i * 4, 0);\n"
+ " seek(PROFILE, $i * ($address_length / 2), 0);\n"
" read(PROFILE, $map, (stat PROFILE)[7]);\n"
- " close(PROFILE);\n"
+ "\n"
" my $r = {};\n"
" $r->{version} = $version;\n"
" $r->{period} = $period;\n"
" $r->{profile} = $profile;\n"
" $r->{libs} = ParseLibraries($prog, $map, $pcs);\n"
" $r->{pcs} = $pcs;\n"
+ "\n"
" return $r;\n"
"}\n"
+ "\n"
"sub ReadHeapProfile {\n"
" my $prog = shift;\n"
- " my $fname = shift;\n"
+ " local *PROFILE = shift;\n"
" my $header = shift;\n"
+ "\n"
" my $index = 1;\n"
" if ($main::opt_inuse_space) {\n"
" $index = 1;\n"
@@ -2598,36 +3974,78 @@ const char* pprof_perl() {
" } elsif ($main::opt_alloc_objects) {\n"
" $index = 2;\n"
" }\n"
+ "\n"
+ " # Find the type of this profile. The header line looks like:\n"
+ " # heap profile: 1246: 8800744 [ 1246: 8800744] @ <heap-url>/266053\n"
+ " # There are two pairs <count: size>, the first inuse objects/space, and the\n"
+ " # second allocated objects/space. This is followed optionally by a profile\n"
+ " # type, and if that is present, optionally by a sampling frequency.\n"
+ " # For remote heap profiles (v1):\n"
+ " # The interpretation of the sampling frequency is that the profiler, for\n"
+ " # each sample, calculates a uniformly distributed random integer less than\n"
+ " # the given value, and records the next sample after that many bytes have\n"
+ " # been allocated. Therefore, the expected sample interval is half of the\n"
+ " # given frequency. By default, if not specified, the expected sample\n"
+ " # interval is 128KB. Only remote-heap-page profiles are adjusted for\n"
+ " # sample size.\n"
+ " # For remote heap profiles (v2):\n"
+ " # The sampling frequency is the rate of a Poisson process. This means that\n"
+ " # the probability of sampling an allocation of size X with sampling rate Y\n"
+ " # is 1 - exp(-X/Y)\n"
+ " # For version 2, a typical header line might look like this:\n"
+ " # heap profile: 1922: 127792360 [ 1922: 127792360] @ <heap-url>_v2/524288\n"
+ " # the trailing number (524288) is the sampling rate. (Version 1 showed\n"
+ " # double the 'rate' here)\n"
" my $sampling_algorithm = 0;\n"
" my $sample_adjustment = 0;\n"
" chomp($header);\n"
" my $type = \"unknown\";\n"
- " if ($header =~ m\"^heap profile:\\s*(\\d+):\\s+(\\d+)\\s+\\[\\s*(\\d+):\\s+(\\d+)\\](\\s*@\\s*([^/]*)(/(\\d+))?)?\") {\n"
+ " if ($header =~ m\"^heap "
+ "profile:\\s*(\\d+):\\s+(\\d+)\\s+\\[\\s*(\\d+):\\s+(\\d+)\\](\\s*@\\s*([^/]*)(/"
+ "(\\d+))?)?\") {\n"
" if (defined($6) && ($6 ne '')) {\n"
" $type = $6;\n"
" my $sample_period = $8;\n"
+ " # $type is \"heapprofile\" for profiles generated by the\n"
+ " # heap-profiler, and either \"heap\" or \"heap_v2\" for profiles\n"
+ " # generated by sampling directly within tcmalloc. It can also\n"
+ " # be \"growth\" for heap-growth profiles. The first is typically\n"
+ " # found for profiles generated locally, and the others for\n"
+ " # remote profiles.\n"
" if (($type eq \"heapprofile\") || ($type !~ /heap/) ) {\n"
+ " # No need to adjust for the sampling rate with heap-profiler-derived data\n"
" $sampling_algorithm = 0;\n"
" } elsif ($type =~ /_v2/) {\n"
- " $sampling_algorithm = 2;\n"
+ " $sampling_algorithm = 2; # version 2 sampling\n"
" if (defined($sample_period) && ($sample_period ne '')) {\n"
" $sample_adjustment = int($sample_period);\n"
" }\n"
" } else {\n"
- " $sampling_algorithm = 1;\n"
+ " $sampling_algorithm = 1; # version 1 sampling\n"
" if (defined($sample_period) && ($sample_period ne '')) {\n"
" $sample_adjustment = int($sample_period)/2;\n"
" }\n"
" }\n"
" } else {\n"
+ " # We detect whether or not this is a remote-heap profile by checking\n"
+ " # that the total-allocated stats ($n2,$s2) are exactly the\n"
+ " # same as the in-use stats ($n1,$s1). It is remotely conceivable\n"
+ " # that a non-remote-heap profile may pass this check, but it is hard\n"
+ " # to imagine how that could happen.\n"
+ " # In this case it's so old it's guaranteed to be remote-heap version 1.\n"
" my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);\n"
" if (($n1 == $n2) && ($s1 == $s2)) {\n"
+ " # This is likely to be a remote-heap based sample profile\n"
" $sampling_algorithm = 1;\n"
" }\n"
" }\n"
" }\n"
+ "\n"
" if ($sampling_algorithm > 0) {\n"
+ " # For remote-heap generated profiles, adjust the counts and sizes to\n"
+ " # account for the sample rate (we sample once every 128KB by default).\n"
" if ($sample_adjustment == 0) {\n"
+ " # Turn on profile adjustment.\n"
" $sample_adjustment = 128*1024;\n"
" print STDERR \"Adjusting heap profiles for 1-in-128KB sampling rate\\n\";\n"
" } else {\n"
@@ -2635,51 +4053,72 @@ const char* pprof_perl() {
" $sample_adjustment);\n"
" }\n"
" if ($sampling_algorithm > 1) {\n"
+ " # We don't bother printing anything for the original version (version 1)\n"
" printf STDERR \"Heap version $sampling_algorithm\\n\";\n"
" }\n"
" }\n"
+ "\n"
" my $profile = {};\n"
" my $pcs = {};\n"
" my $map = \"\";\n"
+ "\n"
" while (<PROFILE>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" if (/^MAPPED_LIBRARIES:/) {\n"
+ " # Read the /proc/self/maps data\n"
" while (<PROFILE>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" $map .= $_;\n"
" }\n"
" last;\n"
" }\n"
+ "\n"
" if (/^--- Memory map:/) {\n"
+ " # Read /proc/self/maps data as formatted by DumpAddressMap()\n"
" my $buildvar = \"\";\n"
" while (<PROFILE>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
+ " # Parse \"build=<dir>\" specification if supplied\n"
" if (m/^\\s*build=(.*)\\n/) {\n"
" $buildvar = $1;\n"
" }\n"
+ "\n"
+ " # Expand \"$build\" variable if available\n"
" $_ =~ s/\\$build\\b/$buildvar/g;\n"
+ "\n"
" $map .= $_;\n"
" }\n"
" last;\n"
" }\n"
+ "\n"
+ " # Read entry of the form:\n"
+ " # <count1>: <bytes1> [<count2>: <bytes2>] @ a1 a2 a3 ... an\n"
" s/^\\s*//;\n"
" s/\\s*$//;\n"
" if (m/^\\s*(\\d+):\\s+(\\d+)\\s+\\[\\s*(\\d+):\\s+(\\d+)\\]\\s+@\\s+(.*)$/) {\n"
" my $stack = $5;\n"
" my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);\n"
+ "\n"
" if ($sample_adjustment) {\n"
" if ($sampling_algorithm == 2) {\n"
- " my $ratio;\n"
- " $ratio = (($s1*1.0)/$n1)/($sample_adjustment);\n"
- " my $scale_factor;\n"
- " $scale_factor = 1/(1 - exp(-$ratio));\n"
- " $n1 *= $scale_factor;\n"
- " $s1 *= $scale_factor;\n"
- " $ratio = (($s2*1.0)/$n2)/($sample_adjustment);\n"
- " $scale_factor = 1/(1 - exp(-$ratio));\n"
- " $n2 *= $scale_factor;\n"
- " $s2 *= $scale_factor;\n"
+ " # Remote-heap version 2\n"
+ " # The sampling frequency is the rate of a Poisson process.\n"
+ " # This means that the probability of sampling an allocation of\n"
+ " # size X with sampling rate Y is 1 - exp(-X/Y)\n"
+ " if ($n1 != 0) {\n"
+ " my $ratio = (($s1*1.0)/$n1)/($sample_adjustment);\n"
+ " my $scale_factor = 1/(1 - exp(-$ratio));\n"
+ " $n1 *= $scale_factor;\n"
+ " $s1 *= $scale_factor;\n"
+ " }\n"
+ " if ($n2 != 0) {\n"
+ " my $ratio = (($s2*1.0)/$n2)/($sample_adjustment);\n"
+ " my $scale_factor = 1/(1 - exp(-$ratio));\n"
+ " $n2 *= $scale_factor;\n"
+ " $s2 *= $scale_factor;\n"
+ " }\n"
" } else {\n"
+ " # Remote-heap version 1\n"
" my $ratio;\n"
" $ratio = (($s1*1.0)/$n1)/($sample_adjustment);\n"
" if ($ratio < 1) {\n"
@@ -2693,10 +4132,14 @@ const char* pprof_perl() {
" }\n"
" }\n"
" }\n"
+ "\n"
" my @counts = ($n1, $s1, $n2, $s2);\n"
- " AddEntries($profile, $pcs, FixCallerAddresses($stack), $counts[$index]);\n"
+ " $stack = FixCallerAddresses($stack);\n"
+ " push @stackTraces, \"$n1 $s1 $n2 $s2 $stack\";\n"
+ " AddEntries($profile, $pcs, $stack, $counts[$index]);\n"
" }\n"
" }\n"
+ "\n"
" my $r = {};\n"
" $r->{version} = \"heap\";\n"
" $r->{period} = 1;\n"
@@ -2705,15 +4148,20 @@ const char* pprof_perl() {
" $r->{pcs} = $pcs;\n"
" return $r;\n"
"}\n"
+ "\n"
"sub ReadSynchProfile {\n"
- " my ($prog, $fname, $header) = @_;\n"
+ " my $prog = shift;\n"
+ " local *PROFILE = shift;\n"
+ " my $header = shift;\n"
+ "\n"
" my $map = '';\n"
" my $profile = {};\n"
" my $pcs = {};\n"
" my $sampling_period = 1;\n"
- " my $cyclespernanosec = 2.8;\n"
+ " my $cyclespernanosec = 2.8; # Default assumption for old binaries\n"
" my $seen_clockrate = 0;\n"
" my $line;\n"
+ "\n"
" my $index = 0;\n"
" if ($main::opt_total_delay) {\n"
" $index = 0;\n"
@@ -2722,24 +4170,37 @@ const char* pprof_perl() {
" } elsif ($main::opt_mean_delay) {\n"
" $index = 2;\n"
" }\n"
+ "\n"
" while ( $line = <PROFILE> ) {\n"
- " $line =~ s/\\r//g;\n"
+ " $line =~ s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" if ( $line =~ /^\\s*(\\d+)\\s+(\\d+) \\@\\s*(.*?)\\s*$/ ) {\n"
" my ($cycles, $count, $stack) = ($1, $2, $3);\n"
+ "\n"
+ " # Convert cycles to nanoseconds\n"
" $cycles /= $cyclespernanosec;\n"
+ "\n"
+ " # Adjust for sampling done by application\n"
" $cycles *= $sampling_period;\n"
" $count *= $sampling_period;\n"
+ "\n"
" my @values = ($cycles, $count, $cycles / $count);\n"
" AddEntries($profile, $pcs, FixCallerAddresses($stack), $values[$index]);\n"
+ "\n"
" } elsif ( $line =~ /^(slow release).*thread \\d+ \\@\\s*(.*?)\\s*$/ ||\n"
" $line =~ /^\\s*(\\d+) \\@\\s*(.*?)\\s*$/ ) {\n"
" my ($cycles, $stack) = ($1, $2);\n"
" if ($cycles !~ /^\\d+$/) {\n"
" next;\n"
" }\n"
+ "\n"
+ " # Convert cycles to nanoseconds\n"
" $cycles /= $cyclespernanosec;\n"
+ "\n"
+ " # Adjust for sampling done by application\n"
" $cycles *= $sampling_period;\n"
+ "\n"
" AddEntries($profile, $pcs, FixCallerAddresses($stack), $cycles);\n"
+ "\n"
" } elsif ( $line =~ m/^([a-z][^=]*)=(.*)$/ ) {\n"
" my ($variable, $value) = ($1,$2);\n"
" for ($variable, $value) {\n"
@@ -2752,20 +4213,26 @@ const char* pprof_perl() {
" } elsif ($variable eq \"sampling period\") {\n"
" $sampling_period = $value;\n"
" } elsif ($variable eq \"ms since reset\") {\n"
+ " # Currently nothing is done with this value in pprof\n"
+ " # So we just silently ignore it for now\n"
" } elsif ($variable eq \"discarded samples\") {\n"
+ " # Currently nothing is done with this value in pprof\n"
+ " # So we just silently ignore it for now\n"
" } else {\n"
" printf STDERR (\"Ignoring unnknown variable in /contention output: \" .\n"
" \"'%s' = '%s'\\n\",$variable,$value);\n"
" }\n"
" } else {\n"
+ " # Memory map entry\n"
" $map .= $line;\n"
" }\n"
" }\n"
- " close PROFILE;\n"
+ "\n"
" if (!$seen_clockrate) {\n"
" printf STDERR (\"No cycles/second entry in profile; Guessing %.1f GHz\\n\",\n"
" $cyclespernanosec);\n"
" }\n"
+ "\n"
" my $r = {};\n"
" $r->{version} = 0;\n"
" $r->{period} = $sampling_period;\n"
@@ -2774,17 +4241,41 @@ const char* pprof_perl() {
" $r->{pcs} = $pcs;\n"
" return $r;\n"
"}\n"
+ "\n"
+ "# Given a hex value in the form \"0x1abcd\" or \"1abcd\", return either\n"
+ "# \"0001abcd\" or \"000000000001abcd\", depending on the current (global)\n"
+ "# address length.\n"
"sub HexExtend {\n"
" my $addr = shift;\n"
- " $addr =~ s/^0x//;\n"
- " if (length $addr > $address_length) {\n"
- " printf STDERR \"Warning: address $addr is longer than address length $address_length\\n\";\n"
- " }\n"
- " return substr(\"000000000000000\".$addr, -$address_length);\n"
+ "\n"
+ " $addr =~ s/^(0x)?0*//;\n"
+ " my $zeros_needed = $address_length - length($addr);\n"
+ " if ($zeros_needed < 0) {\n"
+ " printf STDERR \"Warning: address $addr is longer than address length "
+ "$address_length\\n\";\n"
+ " return $addr;\n"
+ " }\n"
+ " return (\"0\" x $zeros_needed) . $addr;\n"
"}\n"
+ "\n"
+ "##### Symbol extraction #####\n"
+ "\n"
+ "# Aggressively search the lib_prefix values for the given library\n"
+ "# If all else fails, just return the name of the library unmodified.\n"
+ "# If the lib_prefix is \"/my/path,/other/path\" and $file is \"/lib/dir/mylib.so\"\n"
+ "# it will search the following locations in this order, until it finds a file:\n"
+ "# /my/path/lib/dir/mylib.so\n"
+ "# /other/path/lib/dir/mylib.so\n"
+ "# /my/path/dir/mylib.so\n"
+ "# /other/path/dir/mylib.so\n"
+ "# /my/path/mylib.so\n"
+ "# /other/path/mylib.so\n"
+ "# /lib/dir/mylib.so (returned as last resort)\n"
"sub FindLibrary {\n"
" my $file = shift;\n"
" my $suffix = $file;\n"
+ "\n"
+ " # Search for the library as described above\n"
" do {\n"
" foreach my $prefix (@prefix_list) {\n"
" my $fullpath = $prefix . $suffix;\n"
@@ -2795,23 +4286,37 @@ const char* pprof_perl() {
" } while ($suffix =~ s|^/[^/]+/|/|);\n"
" return $file;\n"
"}\n"
+ "\n"
+ "# Return path to library with debugging symbols.\n"
+ "# For libc libraries, the copy in /usr/lib/debug contains debugging symbols\n"
"sub DebuggingLibrary {\n"
" my $file = shift;\n"
" if ($file =~ m|^/| && -f \"/usr/lib/debug$file\") {\n"
" return \"/usr/lib/debug$file\";\n"
" }\n"
+ " if ($file =~ m|^/| && -f \"/usr/lib/debug$file.debug\") {\n"
+ " return \"/usr/lib/debug$file.debug\";\n"
+ " }\n"
" return undef;\n"
"}\n"
+ "\n"
+ "# Parse text section header of a library using objdump\n"
"sub ParseTextSectionHeaderFromObjdump {\n"
" my $lib = shift;\n"
+ "\n"
" my $size = undef;\n"
" my $vma;\n"
" my $file_offset;\n"
- " my $objdump = $obj_tool_map{\"objdump\"};\n"
- " open(OBJDUMP, \"$objdump -h $lib |\")\n"
- " || error(\"$objdump $lib: $!\\n\");\n"
+ " # Get objdump output from the library file to figure out how to\n"
+ " # map between mapped addresses and addresses in the library.\n"
+ " my $cmd = ShellEscape($obj_tool_map{\"objdump\"}, \"-h\", $lib);\n"
+ " open(OBJDUMP, \"$cmd |\") || error(\"$cmd: $!\\n\");\n"
" while (<OBJDUMP>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
+ " # Idx Name Size VMA LMA File off Algn\n"
+ " # 10 .text 00104b2c 420156f0 420156f0 000156f0 2**4\n"
+ " # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file\n"
+ " # offset may still be 8. But AddressSub below will still handle that.\n"
" my @x = split;\n"
" if (($#x >= 6) && ($x[1] eq '.text')) {\n"
" $size = $x[2];\n"
@@ -2821,28 +4326,47 @@ const char* pprof_perl() {
" }\n"
" }\n"
" close(OBJDUMP);\n"
+ "\n"
" if (!defined($size)) {\n"
" return undef;\n"
" }\n"
+ "\n"
" my $r = {};\n"
" $r->{size} = $size;\n"
" $r->{vma} = $vma;\n"
" $r->{file_offset} = $file_offset;\n"
+ "\n"
" return $r;\n"
"}\n"
+ "\n"
+ "# Parse text section header of a library using otool (on OS X)\n"
"sub ParseTextSectionHeaderFromOtool {\n"
" my $lib = shift;\n"
+ "\n"
" my $size = undef;\n"
" my $vma = undef;\n"
" my $file_offset = undef;\n"
- " my $otool = $obj_tool_map{\"otool\"};\n"
- " open(OTOOL, \"$otool -l $lib |\")\n"
- " || error(\"$otool $lib: $!\\n\");\n"
+ " # Get otool output from the library file to figure out how to\n"
+ " # map between mapped addresses and addresses in the library.\n"
+ " my $command = ShellEscape($obj_tool_map{\"otool\"}, \"-l\", $lib);\n"
+ " open(OTOOL, \"$command |\") || error(\"$command: $!\\n\");\n"
" my $cmd = \"\";\n"
" my $sectname = \"\";\n"
" my $segname = \"\";\n"
" foreach my $line (<OTOOL>) {\n"
- " $line =~ s/\\r//g;\n"
+ " $line =~ s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
+ " # Load command <#>\n"
+ " # cmd LC_SEGMENT\n"
+ " # [...]\n"
+ " # Section\n"
+ " # sectname __text\n"
+ " # segname __TEXT\n"
+ " # addr 0x000009f8\n"
+ " # size 0x00018b9e\n"
+ " # offset 2552\n"
+ " # align 2^2 (4)\n"
+ " # We will need to strip off the leading 0x from the hex addresses,\n"
+ " # and convert the offset into hex.\n"
" if ($line =~ /Load command/) {\n"
" $cmd = \"\";\n"
" $sectname = \"\";\n"
@@ -2872,57 +4396,94 @@ const char* pprof_perl() {
" }\n"
" }\n"
" close(OTOOL);\n"
+ "\n"
" if (!defined($vma) || !defined($size) || !defined($file_offset)) {\n"
" return undef;\n"
" }\n"
+ "\n"
" my $r = {};\n"
" $r->{size} = $size;\n"
" $r->{vma} = $vma;\n"
" $r->{file_offset} = $file_offset;\n"
+ "\n"
" return $r;\n"
"}\n"
+ "\n"
"sub ParseTextSectionHeader {\n"
+ " # obj_tool_map(\"otool\") is only defined if we're in a Mach-O environment\n"
" if (defined($obj_tool_map{\"otool\"})) {\n"
" my $r = ParseTextSectionHeaderFromOtool(@_);\n"
" if (defined($r)){\n"
" return $r;\n"
" }\n"
" }\n"
+ " # If otool doesn't work, or we don't have it, fall back to objdump\n"
" return ParseTextSectionHeaderFromObjdump(@_);\n"
"}\n"
+ "\n"
+ "# Split /proc/pid/maps dump into a list of libraries\n"
"sub ParseLibraries {\n"
- " return if $main::use_symbol_page;\n"
- " my $prog = shift;\n"
+ " return if $main::use_symbol_page; # We don't need libraries info.\n"
+ " my $prog = Cwd::abs_path(shift);\n"
" my $map = shift;\n"
" my $pcs = shift;\n"
+ "\n"
" my $result = [];\n"
" my $h = \"[a-f0-9]+\";\n"
" my $zero_offset = HexExtend(\"0\");\n"
+ "\n"
" my $buildvar = \"\";\n"
" foreach my $l (split(\"\\n\", $map)) {\n"
" if ($l =~ m/^\\s*build=(.*)$/) {\n"
" $buildvar = $1;\n"
" }\n"
+ "\n"
" my $start;\n"
" my $finish;\n"
" my $offset;\n"
" my $lib;\n"
- " if ($l =~ /^($h)-($h)\\s+..x.\\s+($h)\\s+\\S+:\\S+\\s+\\d+\\s+(\\S+\\.(so|dll|dylib|bundle)((\\.\\d+)+\\w*(\\.\\d+){0,3})?)$/i) {\n"
+ " if ($l =~ "
+ "/^($h)-($h)\\s+..x.\\s+($h)\\s+\\S+:\\S+\\s+\\d+\\s+(.+\\.(so|dll|dylib|bundle|node)(("
+ "\\.\\d+)+\\w*(\\.\\d+){0,3})?)$/i) {\n"
+ " # Full line from /proc/self/maps. Example:\n"
+ " # 40000000-40015000 r-xp 00000000 03:01 12845071 /lib/ld-2.3.2.so\n"
" $start = HexExtend($1);\n"
" $finish = HexExtend($2);\n"
" $offset = HexExtend($3);\n"
" $lib = $4;\n"
- " $lib =~ s|\\\\|/|g;\n"
+ " $lib =~ s|\\\\|/|g; # turn windows-style paths into unix-style paths\n"
" } elsif ($l =~ /^\\s*($h)-($h):\\s*(\\S+\\.so(\\.\\d+)*)/) {\n"
+ " # Cooked line from DumpAddressMap. Example:\n"
+ " # 40000000-40015000: /lib/ld-2.3.2.so\n"
" $start = HexExtend($1);\n"
" $finish = HexExtend($2);\n"
" $offset = $zero_offset;\n"
" $lib = $3;\n"
+ " } elsif (($l =~ /^($h)-($h)\\s+..x.\\s+($h)\\s+\\S+:\\S+\\s+\\d+\\s+(\\S+)$/i) && "
+ "($4 eq $prog)) {\n"
+ " # PIEs and address space randomization do not play well with our\n"
+ " # default assumption that main executable is at lowest\n"
+ " # addresses. So we're detecting main executable in\n"
+ " # /proc/self/maps as well.\n"
+ " $start = HexExtend($1);\n"
+ " $finish = HexExtend($2);\n"
+ " $offset = HexExtend($3);\n"
+ " $lib = $4;\n"
+ " $lib =~ s|\\\\|/|g; # turn windows-style paths into unix-style paths\n"
" } else {\n"
" next;\n"
" }\n"
+ "\n"
+ " # Expand \"$build\" variable if available\n"
" $lib =~ s/\\$build\\b/$buildvar/g;\n"
+ "\n"
" $lib = FindLibrary($lib);\n"
+ "\n"
+ " # Check for pre-relocated libraries, which use pre-relocated symbol tables\n"
+ " # and thus require adjusting the offset that we'll use to translate\n"
+ " # VM addresses into symbol table addresses.\n"
+ " # Only do this if we're not going to fetch the symbol table from a\n"
+ " # debugging copy of the library.\n"
" if (!DebuggingLibrary($lib)) {\n"
" my $text = ParseTextSectionHeader($lib);\n"
" if (defined($text)) {\n"
@@ -2930,35 +4491,54 @@ const char* pprof_perl() {
" $offset = AddressAdd($offset, $vma_offset);\n"
" }\n"
" }\n"
+ "\n"
" push(@{$result}, [$lib, $start, $finish, $offset]);\n"
" }\n"
+ "\n"
+ " # Append special entry for additional library (not relocated)\n"
" if ($main::opt_lib ne \"\") {\n"
" my $text = ParseTextSectionHeader($main::opt_lib);\n"
" if (defined($text)) {\n"
" my $start = $text->{vma};\n"
" my $finish = AddressAdd($start, $text->{size});\n"
+ "\n"
" push(@{$result}, [$main::opt_lib, $start, $finish, $start]);\n"
" }\n"
" }\n"
+ "\n"
+ " # Append special entry for the main program. This covers\n"
+ " # 0..max_pc_value_seen, so that we assume pc values not found in one\n"
+ " # of the library ranges will be treated as coming from the main\n"
+ " # program binary.\n"
" my $min_pc = HexExtend(\"0\");\n"
- " my $max_pc = $min_pc;\n"
+ " my $max_pc = $min_pc; # find the maximal PC value in any sample\n"
" foreach my $pc (keys(%{$pcs})) {\n"
" if (HexExtend($pc) gt $max_pc) { $max_pc = HexExtend($pc); }\n"
" }\n"
" push(@{$result}, [$prog, $min_pc, $max_pc, $zero_offset]);\n"
+ "\n"
" return $result;\n"
"}\n"
+ "\n"
+ "# Add two hex addresses of length $address_length.\n"
+ "# Run pprof --test for unit test if this is changed.\n"
"sub AddressAdd {\n"
" my $addr1 = shift;\n"
" my $addr2 = shift;\n"
" my $sum;\n"
+ "\n"
" if ($address_length == 8) {\n"
+ " # Perl doesn't cope with wraparound arithmetic, so do it explicitly:\n"
" $sum = (hex($addr1)+hex($addr2)) % (0x10000000 * 16);\n"
" return sprintf(\"%08x\", $sum);\n"
+ "\n"
" } else {\n"
+ " # Do the addition in 7-nibble chunks to trivialize carry handling.\n"
+ "\n"
" if ($main::opt_debug and $main::opt_test) {\n"
" print STDERR \"AddressAdd $addr1 + $addr2 = \";\n"
" }\n"
+ "\n"
" my $a1 = substr($addr1,-7);\n"
" $addr1 = substr($addr1,0,-7);\n"
" my $a2 = substr($addr2,-7);\n"
@@ -2970,6 +4550,7 @@ const char* pprof_perl() {
" $sum -= 0x10000000;\n"
" }\n"
" my $r = sprintf(\"%07x\", $sum);\n"
+ "\n"
" $a1 = substr($addr1,-7);\n"
" $addr1 = substr($addr1,0,-7);\n"
" $a2 = substr($addr2,-7);\n"
@@ -2981,21 +4562,34 @@ const char* pprof_perl() {
" $sum -= 0x10000000;\n"
" }\n"
" $r = sprintf(\"%07x\", $sum) . $r;\n"
+ "\n"
" $sum = hex($addr1) + hex($addr2) + $c;\n"
" if ($sum > 0xff) { $sum -= 0x100; }\n"
" $r = sprintf(\"%02x\", $sum) . $r;\n"
+ "\n"
" if ($main::opt_debug and $main::opt_test) { print STDERR \"$r\\n\"; }\n"
+ "\n"
" return $r;\n"
" }\n"
"}\n"
+ "\n"
+ "\n"
+ "# Subtract two hex addresses of length $address_length.\n"
+ "# Run pprof --test for unit test if this is changed.\n"
"sub AddressSub {\n"
" my $addr1 = shift;\n"
" my $addr2 = shift;\n"
" my $diff;\n"
+ "\n"
" if ($address_length == 8) {\n"
+ " # Perl doesn't cope with wraparound arithmetic, so do it explicitly:\n"
" $diff = (hex($addr1)-hex($addr2)) % (0x10000000 * 16);\n"
" return sprintf(\"%08x\", $diff);\n"
+ "\n"
" } else {\n"
+ " # Do the addition in 7-nibble chunks to trivialize borrow handling.\n"
+ " # if ($main::opt_debug) { print STDERR \"AddressSub $addr1 - $addr2 = \"; }\n"
+ "\n"
" my $a1 = hex(substr($addr1,-7));\n"
" $addr1 = substr($addr1,0,-7);\n"
" my $a2 = hex(substr($addr2,-7));\n"
@@ -3007,6 +4601,7 @@ const char* pprof_perl() {
" }\n"
" $diff = $a1 - $a2;\n"
" my $r = sprintf(\"%07x\", $diff);\n"
+ "\n"
" $a1 = hex(substr($addr1,-7));\n"
" $addr1 = substr($addr1,0,-7);\n"
" $a2 = hex(substr($addr2,-7)) + $b;\n"
@@ -3018,98 +4613,175 @@ const char* pprof_perl() {
" }\n"
" $diff = $a1 - $a2;\n"
" $r = sprintf(\"%07x\", $diff) . $r;\n"
+ "\n"
" $a1 = hex($addr1);\n"
" $a2 = hex($addr2) + $b;\n"
" if ($a2 > $a1) { $a1 += 0x100; }\n"
" $diff = $a1 - $a2;\n"
" $r = sprintf(\"%02x\", $diff) . $r;\n"
+ "\n"
+ " # if ($main::opt_debug) { print STDERR \"$r\\n\"; }\n"
+ "\n"
" return $r;\n"
" }\n"
"}\n"
+ "\n"
+ "# Increment a hex addresses of length $address_length.\n"
+ "# Run pprof --test for unit test if this is changed.\n"
"sub AddressInc {\n"
" my $addr = shift;\n"
" my $sum;\n"
+ "\n"
" if ($address_length == 8) {\n"
+ " # Perl doesn't cope with wraparound arithmetic, so do it explicitly:\n"
" $sum = (hex($addr)+1) % (0x10000000 * 16);\n"
" return sprintf(\"%08x\", $sum);\n"
+ "\n"
" } else {\n"
+ " # Do the addition in 7-nibble chunks to trivialize carry handling.\n"
+ " # We are always doing this to step through the addresses in a function,\n"
+ " # and will almost never overflow the first chunk, so we check for this\n"
+ " # case and exit early.\n"
+ "\n"
+ " # if ($main::opt_debug) { print STDERR \"AddressInc $addr1 = \"; }\n"
+ "\n"
" my $a1 = substr($addr,-7);\n"
" $addr = substr($addr,0,-7);\n"
" $sum = hex($a1) + 1;\n"
" my $r = sprintf(\"%07x\", $sum);\n"
" if ($sum <= 0xfffffff) {\n"
" $r = $addr . $r;\n"
+ " # if ($main::opt_debug) { print STDERR \"$r\\n\"; }\n"
" return HexExtend($r);\n"
" } else {\n"
" $r = \"0000000\";\n"
" }\n"
+ "\n"
" $a1 = substr($addr,-7);\n"
" $addr = substr($addr,0,-7);\n"
" $sum = hex($a1) + 1;\n"
" $r = sprintf(\"%07x\", $sum) . $r;\n"
" if ($sum <= 0xfffffff) {\n"
" $r = $addr . $r;\n"
+ " # if ($main::opt_debug) { print STDERR \"$r\\n\"; }\n"
" return HexExtend($r);\n"
" } else {\n"
" $r = \"00000000000000\";\n"
" }\n"
+ "\n"
" $sum = hex($addr) + 1;\n"
" if ($sum > 0xff) { $sum -= 0x100; }\n"
" $r = sprintf(\"%02x\", $sum) . $r;\n"
+ "\n"
+ " # if ($main::opt_debug) { print STDERR \"$r\\n\"; }\n"
" return $r;\n"
" }\n"
"}\n"
+ "\n"
+ "# Extract symbols for all PC values found in profile\n"
"sub ExtractSymbols {\n"
" my $libs = shift;\n"
" my $pcset = shift;\n"
+ "\n"
" my $symbols = {};\n"
- " my %seen = ();\n"
- " foreach my $lib (@{$libs}) {\n"
+ "\n"
+ " # Map each PC value to the containing library. To make this faster,\n"
+ " # we sort libraries by their starting pc value (highest first), and\n"
+ " # advance through the libraries as we advance the pc. Sometimes the\n"
+ " # addresses of libraries may overlap with the addresses of the main\n"
+ " # binary, so to make sure the libraries 'win', we iterate over the\n"
+ " # libraries in reverse order (which assumes the binary doesn't start\n"
+ " # in the middle of a library, which seems a fair assumption).\n"
+ " my @pcs = (sort { $a cmp $b } keys(%{$pcset})); # pcset is 0-extended strings\n"
+ " foreach my $lib (sort {$b->[1] cmp $a->[1]} @{$libs}) {\n"
" my $libname = $lib->[0];\n"
" my $start = $lib->[1];\n"
" my $finish = $lib->[2];\n"
" my $offset = $lib->[3];\n"
+ "\n"
+ " # Get list of pcs that belong in this library.\n"
" my $contained = [];\n"
- " foreach my $pc (keys(%{$pcset})) {\n"
- " if (!$seen{$pc} && ($pc ge $start) && ($pc le $finish)) {\n"
- " $seen{$pc} = 1;\n"
- " push(@{$contained}, $pc);\n"
- " }\n"
- " }\n"
+ " my ($start_pc_index, $finish_pc_index);\n"
+ " # Find smallest finish_pc_index such that $finish < $pc[$finish_pc_index].\n"
+ " for ($finish_pc_index = $#pcs + 1; $finish_pc_index > 0;\n"
+ " $finish_pc_index--) {\n"
+ " last if $pcs[$finish_pc_index - 1] le $finish;\n"
+ " }\n"
+ " # Find smallest start_pc_index such that $start <= $pc[$start_pc_index].\n"
+ " for ($start_pc_index = $finish_pc_index; $start_pc_index > 0;\n"
+ " $start_pc_index--) {\n"
+ " last if $pcs[$start_pc_index - 1] lt $start;\n"
+ " }\n"
+ " # This keeps PC values higher than $pc[$finish_pc_index] in @pcs,\n"
+ " # in case there are overlaps in libraries and the main binary.\n"
+ " @{$contained} = splice(@pcs, $start_pc_index,\n"
+ " $finish_pc_index - $start_pc_index);\n"
+ " # Map to symbols\n"
" MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols);\n"
" }\n"
+ "\n"
" return $symbols;\n"
"}\n"
+ "\n"
+ "# Map list of PC values to symbols for a given image\n"
"sub MapToSymbols {\n"
" my $image = shift;\n"
" my $offset = shift;\n"
" my $pclist = shift;\n"
" my $symbols = shift;\n"
+ "\n"
" my $debug = 0;\n"
+ "\n"
+ " # For libc (and other) libraries, the copy in /usr/lib/debug contains debugging "
+ "symbols\n"
+ " my $debugging = DebuggingLibrary($image);\n"
+ " if ($debugging) {\n"
+ " $image = $debugging;\n"
+ " }\n"
+ "\n"
+ " # Ignore empty binaries\n"
" if ($#{$pclist} < 0) { return; }\n"
+ "\n"
+ " # Figure out the addr2line command to use\n"
" my $addr2line = $obj_tool_map{\"addr2line\"};\n"
- " my $cmd = \"$addr2line -f -C -e $image\";\n"
+ " my $cmd = ShellEscape($addr2line, \"-f\", \"-C\", \"-e\", $image);\n"
" if (exists $obj_tool_map{\"addr2line_pdb\"}) {\n"
" $addr2line = $obj_tool_map{\"addr2line_pdb\"};\n"
- " $cmd = \"$addr2line --demangle -f -C -e $image\";\n"
+ " $cmd = ShellEscape($addr2line, \"--demangle\", \"-f\", \"-C\", \"-e\", $image);\n"
" }\n"
- " if (system(\"$addr2line --help >/dev/null 2>&1\") != 0) {\n"
+ "\n"
+ " # If \"addr2line\" isn't installed on the system at all, just use\n"
+ " # nm to get what info we can (function names, but not line numbers).\n"
+ " if (system(ShellEscape($addr2line, \"--help\") . \" >$dev_null 2>&1\") != 0) {\n"
" MapSymbolsWithNM($image, $offset, $pclist, $symbols);\n"
" return;\n"
" }\n"
- " $sep_address = undef;\n"
+ "\n"
+ " # \"addr2line -i\" can produce a variable number of lines per input\n"
+ " # address, with no separator that allows us to tell when data for\n"
+ " # the next address starts. So we find the address for a special\n"
+ " # symbol (_fini) and interleave this address between all real\n"
+ " # addresses passed to addr2line. The name of this special symbol\n"
+ " # can then be used as a separator.\n"
+ " $sep_address = undef; # May be filled in by MapSymbolsWithNM()\n"
" my $nm_symbols = {};\n"
" MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols);\n"
" if (defined($sep_address)) {\n"
- " if (system(\"$cmd -i --help >/dev/null 2>&1\") == 0) {\n"
+ " # Only add \" -i\" to addr2line if the binary supports it.\n"
+ " # addr2line --help returns 0, but not if it sees an unknown flag first.\n"
+ " if (system(\"$cmd -i --help >$dev_null 2>&1\") == 0) {\n"
" $cmd .= \" -i\";\n"
" } else {\n"
- " $sep_address = undef;\n"
+ " $sep_address = undef; # no need for sep_address if we don't support -i\n"
" }\n"
" }\n"
+ "\n"
+ " # Make file with all PC values with intervening 'sep_address' so\n"
+ " # that we can reliably detect the end of inlined function list\n"
" open(ADDRESSES, \">$main::tmpfile_sym\") || error(\"$main::tmpfile_sym: $!\\n\");\n"
" if ($debug) { print(\"---- $image ---\\n\"); }\n"
" for (my $i = 0; $i <= $#{$pclist}; $i++) {\n"
+ " # addr2line always reads hex addresses, and does not need '0x' prefix.\n"
" if ($debug) { printf STDERR (\"%s\\n\", $pclist->[$i]); }\n"
" printf ADDRESSES (\"%s\\n\", AddressSub($pclist->[$i], $offset));\n"
" if (defined($sep_address)) {\n"
@@ -3119,33 +4791,64 @@ const char* pprof_perl() {
" close(ADDRESSES);\n"
" if ($debug) {\n"
" print(\"----\\n\");\n"
- " system(\"cat $main::tmpfile_sym\");\n"
- " print(\"----\\n\");\n"
- " system(\"$cmd <$main::tmpfile_sym\");\n"
+ " system(\"cat\", $main::tmpfile_sym);\n"
+ " print(\"---- $cmd ---\\n\");\n"
+ " system(\"$cmd < \" . ShellEscape($main::tmpfile_sym));\n"
" print(\"----\\n\");\n"
" }\n"
- " open(SYMBOLS, \"$cmd <$main::tmpfile_sym |\") || error(\"$cmd: $!\\n\");\n"
- " my $count = 0;\n"
+ "\n"
+ " open(SYMBOLS, \"$cmd <\" . ShellEscape($main::tmpfile_sym) . \" |\")\n"
+ " || error(\"$cmd: $!\\n\");\n"
+ " my $count = 0; # Index in pclist\n"
" while (<SYMBOLS>) {\n"
+ " # Read fullfunction and filelineinfo from next pair of lines\n"
" s/\\r?\\n$//g;\n"
" my $fullfunction = $_;\n"
" $_ = <SYMBOLS>;\n"
" s/\\r?\\n$//g;\n"
" my $filelinenum = $_;\n"
+ "\n"
" if (defined($sep_address) && $fullfunction eq $sep_symbol) {\n"
+ " # Terminating marker for data for this address\n"
" $count++;\n"
" next;\n"
" }\n"
- " $filelinenum =~ s|\\\\|/|g;\n"
+ "\n"
+ " $filelinenum =~ s|\\\\|/|g; # turn windows-style paths into unix-style paths\n"
+ "\n"
+ " # Remove discriminator markers as this comes after the line number and\n"
+ " # confuses the rest of this script.\n"
+ " $filelinenum =~ s/ \\(discriminator \\d+\\)$//;\n"
+ " # Convert unknown line numbers into line 0.\n"
+ " $filelinenum =~ s/:\\?$/:0/;\n"
+ "\n"
" my $pcstr = $pclist->[$count];\n"
" my $function = ShortFunctionName($fullfunction);\n"
- " if ($fullfunction eq '\?\?') {\n"
- " my $nms = $nm_symbols->{$pcstr};\n"
- " if (defined($nms)) {\n"
+ " my $nms = $nm_symbols->{$pcstr};\n"
+ " if (defined($nms)) {\n"
+ " if ($fullfunction eq '\?\?') {\n"
+ " # nm found a symbol for us.\n"
" $function = $nms->[0];\n"
" $fullfunction = $nms->[2];\n"
+ " } else {\n"
+ " # MapSymbolsWithNM tags each routine with its starting address,\n"
+ " # useful in case the image has multiple occurrences of this\n"
+ " # routine. (It uses a syntax that resembles template paramters,\n"
+ " # that are automatically stripped out by ShortFunctionName().)\n"
+ " # addr2line does not provide the same information. So we check\n"
+ " # if nm disambiguated our symbol, and if so take the annotated\n"
+ " # (nm) version of the routine-name. TODO(csilvers): this won't\n"
+ " # catch overloaded, inlined symbols, which nm doesn't see.\n"
+ " # Better would be to do a check similar to nm's, in this fn.\n"
+ " if ($nms->[2] =~ m/^\\Q$function\\E/) { # sanity check it's the right fn\n"
+ " $function = $nms->[0];\n"
+ " $fullfunction = $nms->[2];\n"
+ " }\n"
" }\n"
" }\n"
+ " \n"
+ " # Prepend to accumulated symbols for pcstr\n"
+ " # (so that caller comes before callee)\n"
" my $sym = $symbols->{$pcstr};\n"
" if (!defined($sym)) {\n"
" $sym = [];\n"
@@ -3154,33 +4857,45 @@ const char* pprof_perl() {
" unshift(@{$sym}, $function, $filelinenum, $fullfunction);\n"
" if ($debug) { printf STDERR (\"%s => [%s]\\n\", $pcstr, join(\" \", @{$sym})); }\n"
" if (!defined($sep_address)) {\n"
+ " # Inlining is off, so this entry ends immediately\n"
" $count++;\n"
" }\n"
" }\n"
" close(SYMBOLS);\n"
"}\n"
+ "\n"
+ "# Use nm to map the list of referenced PCs to symbols. Return true iff we\n"
+ "# are able to read procedure information via nm.\n"
"sub MapSymbolsWithNM {\n"
" my $image = shift;\n"
" my $offset = shift;\n"
" my $pclist = shift;\n"
" my $symbols = shift;\n"
+ "\n"
+ " # Get nm output sorted by increasing address\n"
" my $symbol_table = GetProcedureBoundaries($image, \".\");\n"
" if (!%{$symbol_table}) {\n"
" return 0;\n"
" }\n"
+ " # Start addresses are already the right length (8 or 16 hex digits).\n"
" my @names = sort { $symbol_table->{$a}->[0] cmp $symbol_table->{$b}->[0] }\n"
" keys(%{$symbol_table});\n"
+ "\n"
" if ($#names < 0) {\n"
+ " # No symbols: just use addresses\n"
" foreach my $pc (@{$pclist}) {\n"
" my $pcstr = \"0x\" . $pc;\n"
" $symbols->{$pc} = [$pcstr, \"?\", $pcstr];\n"
" }\n"
" return 0;\n"
" }\n"
+ "\n"
+ " # Sort addresses so we can do a join against nm output\n"
" my $index = 0;\n"
" my $fullname = $names[0];\n"
" my $name = ShortFunctionName($fullname);\n"
" foreach my $pc (sort { $a cmp $b } @{$pclist}) {\n"
+ " # Adjust for mapped offset\n"
" my $mpc = AddressSub($pc, $offset);\n"
" while (($index < $#names) && ($mpc ge $symbol_table->{$fullname}->[1])){\n"
" $index++;\n"
@@ -3196,42 +4911,122 @@ const char* pprof_perl() {
" }\n"
" return 1;\n"
"}\n"
+ "\n"
"sub ShortFunctionName {\n"
" my $function = shift;\n"
- " while ($function =~ s/\\([^()]*\\)(\\s*const)?//g) { }\n"
- " while ($function =~ s/<[^<>]*>//g) { }\n"
- " $function =~ s/^.*\\s+(\\w+::)/$1/;\n"
+ " while ($function =~ s/\\([^()]*\\)(\\s*const)?//g) { } # Argument types\n"
+ " $function =~ s/<[0-9a-f]*>$//g; # Remove Address\n"
+ " if (!$main::opt_no_strip_temp) {\n"
+ " while ($function =~ s/<[^<>]*>//g) { } # Remove template arguments\n"
+ " }\n"
+ " $function =~ s/^.*\\s+(\\w+::)/$1/; # Remove leading type\n"
" return $function;\n"
"}\n"
+ "\n"
+ "# Trim overly long symbols found in disassembler output\n"
+ "sub CleanDisassembly {\n"
+ " my $d = shift;\n"
+ " while ($d =~ s/\\([^()%]*\\)(\\s*const)?//g) { } # Argument types, not (%rax)\n"
+ " while ($d =~ s/(\\w+)<[^<>]*>/$1/g) { } # Remove template arguments\n"
+ " return $d;\n"
+ "}\n"
+ "\n"
+ "# Clean file name for display\n"
+ "sub CleanFileName {\n"
+ " my ($f) = @_;\n"
+ " $f =~ s|^/proc/self/cwd/||;\n"
+ " $f =~ s|^\\./||;\n"
+ " return $f;\n"
+ "}\n"
+ "\n"
+ "# Make address relative to section and clean up for display\n"
+ "sub UnparseAddress {\n"
+ " my ($offset, $address) = @_;\n"
+ " $address = AddressSub($address, $offset);\n"
+ " $address =~ s/^0x//;\n"
+ " $address =~ s/^0*//;\n"
+ " return $address;\n"
+ "}\n"
+ "\n"
+ "##### Miscellaneous #####\n"
+ "\n"
+ "# Find the right versions of the above object tools to use. The\n"
+ "# argument is the program file being analyzed, and should be an ELF\n"
+ "# 32-bit or ELF 64-bit executable file. The location of the tools\n"
+ "# is determined by considering the following options in this order:\n"
+ "# 1) --tools option, if set\n"
+ "# 2) PPROF_TOOLS environment variable, if set\n"
+ "# 3) the environment\n"
"sub ConfigureObjTools {\n"
" my $prog_file = shift;\n"
+ "\n"
+ " # Check for the existence of $prog_file because /usr/bin/file does not\n"
+ " # predictably return error status in prod.\n"
" (-e $prog_file) || error(\"$prog_file does not exist.\\n\");\n"
- " my $file_type = `/usr/bin/file -L $prog_file 2>/dev/null || /usr/bin/file $prog_file`;\n"
+ "\n"
+ " my $file_type = undef;\n"
+ " if (-e \"/usr/bin/file\") {\n"
+ " # Follow symlinks (at least for systems where \"file\" supports that).\n"
+ " my $escaped_prog_file = ShellEscape($prog_file);\n"
+ " $file_type = `/usr/bin/file -L $escaped_prog_file 2>$dev_null ||\n"
+ " /usr/bin/file $escaped_prog_file`;\n"
+ " } elsif ($^O == \"MSWin32\") {\n"
+ " $file_type = \"MS Windows\";\n"
+ " } else {\n"
+ " print STDERR \"WARNING: Can't determine the file type of $prog_file\";\n"
+ " }\n"
+ "\n"
" if ($file_type =~ /64-bit/) {\n"
+ " # Change $address_length to 16 if the program file is ELF 64-bit.\n"
+ " # We can't detect this from many (most?) heap or lock contention\n"
+ " # profiles, since the actual addresses referenced are generally in low\n"
+ " # memory even for 64-bit programs.\n"
" $address_length = 16;\n"
" }\n"
+ "\n"
" if ($file_type =~ /MS Windows/) {\n"
+ " # For windows, we provide a version of nm and addr2line as part of\n"
+ " # the opensource release, which is capable of parsing\n"
+ " # Windows-style PDB executables. It should live in the path, or\n"
+ " # in the same directory as pprof.\n"
" $obj_tool_map{\"nm_pdb\"} = \"nm-pdb\";\n"
" $obj_tool_map{\"addr2line_pdb\"} = \"addr2line-pdb\";\n"
" }\n"
+ "\n"
" if ($file_type =~ /Mach-O/) {\n"
+ " # OS X uses otool to examine Mach-O files, rather than objdump.\n"
" $obj_tool_map{\"otool\"} = \"otool\";\n"
- " $obj_tool_map{\"addr2line\"} = \"false\";\n"
- " $obj_tool_map{\"objdump\"} = \"false\";\n"
+ " $obj_tool_map{\"addr2line\"} = \"false\"; # no addr2line\n"
+ " $obj_tool_map{\"objdump\"} = \"false\"; # no objdump\n"
" }\n"
+ "\n"
+ " # Go fill in %obj_tool_map with the pathnames to use:\n"
" foreach my $tool (keys %obj_tool_map) {\n"
" $obj_tool_map{$tool} = ConfigureTool($obj_tool_map{$tool});\n"
" }\n"
"}\n"
+ "\n"
+ "# Returns the path of a caller-specified object tool. If --tools or\n"
+ "# PPROF_TOOLS are specified, then returns the full path to the tool\n"
+ "# with that prefix. Otherwise, returns the path unmodified (which\n"
+ "# means we will look for it on PATH).\n"
"sub ConfigureTool {\n"
" my $tool = shift;\n"
" my $path;\n"
+ "\n"
+ " # --tools (or $PPROF_TOOLS) is a comma separated list, where each\n"
+ " # item is either a) a pathname prefix, or b) a map of the form\n"
+ " # <tool>:<path>. First we look for an entry of type (b) for our\n"
+ " # tool. If one is found, we use it. Otherwise, we consider all the\n"
+ " # pathname prefixes in turn, until one yields an existing file. If\n"
+ " # none does, we use a default path.\n"
" my $tools = $main::opt_tools || $ENV{\"PPROF_TOOLS\"} || \"\";\n"
" if ($tools =~ m/(,|^)\\Q$tool\\E:([^,]*)/) {\n"
" $path = $2;\n"
+ " # TODO(csilvers): sanity-check that $path exists? Hard if it's relative.\n"
" } elsif ($tools ne '') {\n"
" foreach my $prefix (split(',', $tools)) {\n"
- " next if ($prefix =~ /:/);\n"
+ " next if ($prefix =~ /:/); # ignore \"tool:fullpath\" entries in the list\n"
" if (-x $prefix . $tool) {\n"
" $path = $prefix . $tool;\n"
" last;\n"
@@ -3242,66 +5037,120 @@ const char* pprof_perl() {
" \"--tools (or \\$PPROF_TOOLS) '$tools'\\n\");\n"
" }\n"
" } else {\n"
- " $0 =~ m,[^/]*$,;\n"
- " my $dirname = $`;\n"
+ " # ... otherwise use the version that exists in the same directory as\n"
+ " # pprof. If there's nothing there, use $PATH.\n"
+ " $0 =~ m,[^/]*$,; # this is everything after the last slash\n"
+ " my $dirname = $`; # this is everything up to and including the last slash\n"
" if (-x \"$dirname$tool\") {\n"
" $path = \"$dirname$tool\";\n"
- " } else {\n"
+ " } else { \n"
" $path = $tool;\n"
" }\n"
" }\n"
" if ($main::opt_debug) { print STDERR \"Using '$path' for '$tool'.\\n\"; }\n"
" return $path;\n"
"}\n"
+ "\n"
+ "sub ShellEscape {\n"
+ " my @escaped_words = ();\n"
+ " foreach my $word (@_) {\n"
+ " my $escaped_word = $word;\n"
+ " if ($word =~ m![^a-zA-Z0-9/.,_=-]!) { # check for anything not in whitelist\n"
+ " $escaped_word =~ s/'/'\\\\''/;\n"
+ " $escaped_word = \"'$escaped_word'\";\n"
+ " }\n"
+ " push(@escaped_words, $escaped_word);\n"
+ " }\n"
+ " return join(\" \", @escaped_words);\n"
+ "}\n"
+ "\n"
"sub cleanup {\n"
" unlink($main::tmpfile_sym);\n"
" unlink(keys %main::tempnames);\n"
+ "\n"
+ " # We leave any collected profiles in $HOME/pprof in case the user wants\n"
+ " # to look at them later. We print a message informing them of this.\n"
" if ((scalar(@main::profile_files) > 0) &&\n"
" defined($main::collected_profile)) {\n"
" if (scalar(@main::profile_files) == 1) {\n"
- " print STDERR \"Dynamically gathered profile is in $main::collected_profile\\n\";\n"
+ " print STDERR \"Dynamically gathered profile is in "
+ "$main::collected_profile\\n\";\n"
" }\n"
" print STDERR \"If you want to investigate this profile further, you can do:\\n\";\n"
" print STDERR \"\\n\";\n"
- " print STDERR \" pprof \\\\\\n\";\n"
+ " print STDERR \" $0 \\\\\\n\";\n"
" print STDERR \" $main::prog \\\\\\n\";\n"
" print STDERR \" $main::collected_profile\\n\";\n"
" print STDERR \"\\n\";\n"
" }\n"
"}\n"
+ "\n"
"sub sighandler {\n"
" cleanup();\n"
" exit(1);\n"
"}\n"
+ "\n"
"sub error {\n"
" my $msg = shift;\n"
" print STDERR $msg;\n"
" cleanup();\n"
" exit(1);\n"
"}\n"
+ "\n"
+ "\n"
+ "# Run $nm_command and get all the resulting procedure boundaries whose\n"
+ "# names match \"$regexp\" and returns them in a hashtable mapping from\n"
+ "# procedure name to a two-element vector of [start address, end address]\n"
"sub GetProcedureBoundariesViaNm {\n"
- " my $nm_command = shift;\n"
+ " my $escaped_nm_command = shift; # shell-escaped\n"
" my $regexp = shift;\n"
+ " my $image = shift;\n"
+ "\n"
" my $symbol_table = {};\n"
- " open(NM, \"$nm_command |\") || error(\"$nm_command: $!\\n\");\n"
+ " open(NM, \"$escaped_nm_command |\") || error(\"$escaped_nm_command: $!\\n\");\n"
" my $last_start = \"0\";\n"
" my $routine = \"\";\n"
" while (<NM>) {\n"
- " s/\\r//g;\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
" if (m/^\\s*([0-9a-f]+) (.) (..*)/) {\n"
" my $start_val = $1;\n"
" my $type = $2;\n"
" my $this_routine = $3;\n"
+ "\n"
+ " # It's possible for two symbols to share the same address, if\n"
+ " # one is a zero-length variable (like __start_google_malloc) or\n"
+ " # one symbol is a weak alias to another (like __libc_malloc).\n"
+ " # In such cases, we want to ignore all values except for the\n"
+ " # actual symbol, which in nm-speak has type \"T\". The logic\n"
+ " # below does this, though it's a bit tricky: what happens when\n"
+ " # we have a series of lines with the same address, is the first\n"
+ " # one gets queued up to be processed. However, it won't\n"
+ " # *actually* be processed until later, when we read a line with\n"
+ " # a different address. That means that as long as we're reading\n"
+ " # lines with the same address, we have a chance to replace that\n"
+ " # item in the queue, which we do whenever we see a 'T' entry --\n"
+ " # that is, a line with type 'T'. If we never see a 'T' entry,\n"
+ " # we'll just go ahead and process the first entry (which never\n"
+ " # got touched in the queue), and ignore the others.\n"
" if ($start_val eq $last_start && $type =~ /t/i) {\n"
+ " # We are the 'T' symbol at this address, replace previous symbol.\n"
" $routine = $this_routine;\n"
" next;\n"
" } elsif ($start_val eq $last_start) {\n"
+ " # We're not the 'T' symbol at this address, so ignore us.\n"
" next;\n"
" }\n"
+ "\n"
" if ($this_routine eq $sep_symbol) {\n"
" $sep_address = HexExtend($start_val);\n"
" }\n"
+ "\n"
+ " # Tag this routine with the starting address in case the image\n"
+ " # has multiple occurrences of this routine. We use a syntax\n"
+ " # that resembles template paramters that are automatically\n"
+ " # stripped out by ShortFunctionName()\n"
" $this_routine .= \"<$start_val>\";\n"
+ "\n"
" if (defined($routine) && $routine =~ m/$regexp/) {\n"
" $symbol_table->{$routine} = [HexExtend($last_start),\n"
" HexExtend($start_val)];\n"
@@ -3309,66 +5158,162 @@ const char* pprof_perl() {
" $last_start = $start_val;\n"
" $routine = $this_routine;\n"
" } elsif (m/^Loaded image name: (.+)/) {\n"
+ " # The win32 nm workalike emits information about the binary it is using.\n"
" if ($main::opt_debug) { print STDERR \"Using Image $1\\n\"; }\n"
" } elsif (m/^PDB file name: (.+)/) {\n"
+ " # The win32 nm workalike emits information about the pdb it is using.\n"
" if ($main::opt_debug) { print STDERR \"Using PDB $1\\n\"; }\n"
" }\n"
" }\n"
" close(NM);\n"
+ " # Handle the last line in the nm output. Unfortunately, we don't know\n"
+ " # how big this last symbol is, because we don't know how big the file\n"
+ " # is. For now, we just give it a size of 0.\n"
+ " # TODO(csilvers): do better here.\n"
" if (defined($routine) && $routine =~ m/$regexp/) {\n"
" $symbol_table->{$routine} = [HexExtend($last_start),\n"
" HexExtend($last_start)];\n"
" }\n"
+ "\n"
+ " # Verify if addr2line can find the $sep_symbol. If not, we use objdump\n"
+ " # to find the address for the $sep_symbol on code section which addr2line\n"
+ " # can find.\n"
+ " if (defined($sep_address)){\n"
+ " my $start_val = $sep_address;\n"
+ " my $addr2line = $obj_tool_map{\"addr2line\"};\n"
+ " my $cmd = ShellEscape($addr2line, \"-f\", \"-C\", \"-e\", $image, \"-i\");\n"
+ " open(FINI, \"echo $start_val | $cmd |\")\n"
+ " || error(\"echo $start_val | $cmd: $!\\n\");\n"
+ " $_ = <FINI>;\n"
+ " s/\\r?\\n$//g;\n"
+ " my $fini = $_;\n"
+ " close(FINI);\n"
+ " if ($fini ne $sep_symbol){\n"
+ " my $objdump = $obj_tool_map{\"objdump\"};\n"
+ " $cmd = ShellEscape($objdump, \"-d\", $image);\n"
+ " my $grep = ShellEscape(\"grep\", $sep_symbol);\n"
+ " my $tail = ShellEscape(\"tail\", \"-n\", \"1\");\n"
+ " open(FINI, \"$cmd | $grep | $tail |\")\n"
+ " || error(\"$cmd | $grep | $tail: $!\\n\");\n"
+ " s/\\r//g; # turn windows-looking lines into unix-looking lines\n"
+ " my $data = <FINI>;\n"
+ " if (defined($data)){\n"
+ " ($start_val, $fini) = split(/ </,$data);\n"
+ " }\n"
+ " close(FINI);\n"
+ " }\n"
+ " $sep_address = HexExtend($start_val);\n"
+ " }\n"
+ "\n"
" return $symbol_table;\n"
"}\n"
+ "\n"
+ "# Gets the procedure boundaries for all routines in \"$image\" whose names\n"
+ "# match \"$regexp\" and returns them in a hashtable mapping from procedure\n"
+ "# name to a two-element vector of [start address, end address].\n"
+ "# Will return an empty map if nm is not installed or not working properly.\n"
"sub GetProcedureBoundaries {\n"
" my $image = shift;\n"
" my $regexp = shift;\n"
+ "\n"
+ " # If $image doesn't start with /, then put ./ in front of it. This works\n"
+ " # around an obnoxious bug in our probing of nm -f behavior.\n"
+ " # \"nm -f $image\" is supposed to fail on GNU nm, but if:\n"
+ " #\n"
+ " # a. $image starts with [BbSsPp] (for example, bin/foo/bar), AND\n"
+ " # b. you have a.out in your current directory (a not uncommon occurrence)\n"
+ " #\n"
+ " # then \"nm -f $image\" succeeds because -f only looks at the first letter of\n"
+ " # the argument, which looks valid because it's [BbSsPp], and then since\n"
+ " # there's no image provided, it looks for a.out and finds it.\n"
+ " #\n"
+ " # This regex makes sure that $image starts with . or /, forcing the -f\n"
+ " # parsing to fail since . and / are not valid formats.\n"
+ " $image =~ s#^[^/]#./$&#;\n"
+ "\n"
+ " # For libc libraries, the copy in /usr/lib/debug contains debugging symbols\n"
" my $debugging = DebuggingLibrary($image);\n"
" if ($debugging) {\n"
" $image = $debugging;\n"
" }\n"
+ "\n"
" my $nm = $obj_tool_map{\"nm\"};\n"
" my $cppfilt = $obj_tool_map{\"c++filt\"};\n"
+ "\n"
+ " # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm\n"
+ " # binary doesn't support --demangle. In addition, for OS X we need\n"
+ " # to use the -f flag to get 'flat' nm output (otherwise we don't sort\n"
+ " # properly and get incorrect results). Unfortunately, GNU nm uses -f\n"
+ " # in an incompatible way. So first we test whether our nm supports\n"
+ " # --demangle and -f.\n"
" my $demangle_flag = \"\";\n"
" my $cppfilt_flag = \"\";\n"
- " if (system(\"$nm --demangle $image >/dev/null 2>&1\") == 0) {\n"
+ " my $to_devnull = \">$dev_null 2>&1\";\n"
+ " if (system(ShellEscape($nm, \"--demangle\", $image) . $to_devnull) == 0) {\n"
+ " # In this mode, we do \"nm --demangle <foo>\"\n"
" $demangle_flag = \"--demangle\";\n"
" $cppfilt_flag = \"\";\n"
- " } elsif (system(\"$cppfilt $image >/dev/null 2>&1\") == 0) {\n"
- " $cppfilt_flag = \" | $cppfilt\";\n"
+ " } elsif (system(ShellEscape($cppfilt, $image) . $to_devnull) == 0) {\n"
+ " # In this mode, we do \"nm <foo> | c++filt\"\n"
+ " $cppfilt_flag = \" | \" . ShellEscape($cppfilt);\n"
" };\n"
" my $flatten_flag = \"\";\n"
- " if (system(\"$nm -f $image >/dev/null 2>&1\") == 0) {\n"
+ " if (system(ShellEscape($nm, \"-f\", $image) . $to_devnull) == 0) {\n"
" $flatten_flag = \"-f\";\n"
" }\n"
- " my @nm_commands = (\"$nm -n $flatten_flag $demangle_flag\" .\n"
- " \" $image 2>/dev/null $cppfilt_flag\",\n"
- " \"$nm -D -n $flatten_flag $demangle_flag\" .\n"
- " \" $image 2>/dev/null $cppfilt_flag\",\n"
- " \"6nm $image 2>/dev/null | sort\",\n"
+ "\n"
+ " # Finally, in the case $imagie isn't a debug library, we try again with\n"
+ " # -D to at least get *exported* symbols. If we can't use --demangle,\n"
+ " # we use c++filt instead, if it exists on this system.\n"
+ " my @nm_commands = (ShellEscape($nm, \"-n\", $flatten_flag, $demangle_flag,\n"
+ " $image) . \" 2>$dev_null $cppfilt_flag\",\n"
+ " ShellEscape($nm, \"-D\", \"-n\", $flatten_flag, $demangle_flag,\n"
+ " $image) . \" 2>$dev_null $cppfilt_flag\",\n"
+ " # 6nm is for Go binaries\n"
+ " ShellEscape(\"6nm\", \"$image\") . \" 2>$dev_null | sort\",\n"
" );\n"
+ "\n"
+ " # If the executable is an MS Windows PDB-format executable, we'll\n"
+ " # have set up obj_tool_map(\"nm_pdb\"). In this case, we actually\n"
+ " # want to use both unix nm and windows-specific nm_pdb, since\n"
+ " # PDB-format executables can apparently include dwarf .o files.\n"
" if (exists $obj_tool_map{\"nm_pdb\"}) {\n"
- " my $nm_pdb = $obj_tool_map{\"nm_pdb\"};\n"
- " push(@nm_commands, \"$nm_pdb --demangle $image 2>/dev/null\");\n"
+ " push(@nm_commands,\n"
+ " ShellEscape($obj_tool_map{\"nm_pdb\"}, \"--demangle\", $image)\n"
+ " . \" 2>$dev_null\");\n"
" }\n"
+ "\n"
" foreach my $nm_command (@nm_commands) {\n"
- " my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp);\n"
+ " my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp, $image);\n"
" return $symbol_table if (%{$symbol_table});\n"
" }\n"
" my $symbol_table = {};\n"
" return $symbol_table;\n"
"}\n"
+ "\n"
+ "\n"
+ "# The test vectors for AddressAdd/Sub/Inc are 8-16-nibble hex strings.\n"
+ "# To make them more readable, we add underscores at interesting places.\n"
+ "# This routine removes the underscores, producing the canonical representation\n"
+ "# used by pprof to represent addresses, particularly in the tested routines.\n"
"sub CanonicalHex {\n"
" my $arg = shift;\n"
" return join '', (split '_',$arg);\n"
"}\n"
+ "\n"
+ "\n"
+ "# Unit test for AddressAdd:\n"
"sub AddressAddUnitTest {\n"
" my $test_data_8 = shift;\n"
" my $test_data_16 = shift;\n"
" my $error_count = 0;\n"
" my $fail_count = 0;\n"
" my $pass_count = 0;\n"
+ " # print STDERR \"AddressAddUnitTest: \", 1+$#{$test_data_8}, \" tests\\n\";\n"
+ "\n"
+ " # First a few 8-nibble addresses. Note that this implementation uses\n"
+ " # plain old arithmetic, so a quick sanity check along with verifying what\n"
+ " # happens to overflow (we want it to wrap):\n"
" $address_length = 8;\n"
" foreach my $row (@{$test_data_8}) {\n"
" if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
@@ -3386,6 +5331,8 @@ const char* pprof_perl() {
" $error_count = $fail_count;\n"
" $fail_count = 0;\n"
" $pass_count = 0;\n"
+ "\n"
+ " # Now 16-nibble addresses.\n"
" $address_length = 16;\n"
" foreach my $row (@{$test_data_16}) {\n"
" if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
@@ -3402,14 +5349,23 @@ const char* pprof_perl() {
" printf STDERR \"AddressAdd 64-bit tests: %d passes, %d failures\\n\",\n"
" $pass_count, $fail_count;\n"
" $error_count += $fail_count;\n"
+ "\n"
" return $error_count;\n"
"}\n"
+ "\n"
+ "\n"
+ "# Unit test for AddressSub:\n"
"sub AddressSubUnitTest {\n"
" my $test_data_8 = shift;\n"
" my $test_data_16 = shift;\n"
" my $error_count = 0;\n"
" my $fail_count = 0;\n"
" my $pass_count = 0;\n"
+ " # print STDERR \"AddressSubUnitTest: \", 1+$#{$test_data_8}, \" tests\\n\";\n"
+ "\n"
+ " # First a few 8-nibble addresses. Note that this implementation uses\n"
+ " # plain old arithmetic, so a quick sanity check along with verifying what\n"
+ " # happens to overflow (we want it to wrap):\n"
" $address_length = 8;\n"
" foreach my $row (@{$test_data_8}) {\n"
" if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
@@ -3427,6 +5383,8 @@ const char* pprof_perl() {
" $error_count = $fail_count;\n"
" $fail_count = 0;\n"
" $pass_count = 0;\n"
+ "\n"
+ " # Now 16-nibble addresses.\n"
" $address_length = 16;\n"
" foreach my $row (@{$test_data_16}) {\n"
" if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
@@ -3442,14 +5400,23 @@ const char* pprof_perl() {
" printf STDERR \"AddressSub 64-bit tests: %d passes, %d failures\\n\",\n"
" $pass_count, $fail_count;\n"
" $error_count += $fail_count;\n"
+ "\n"
" return $error_count;\n"
"}\n"
+ "\n"
+ "\n"
+ "# Unit test for AddressInc:\n"
"sub AddressIncUnitTest {\n"
" my $test_data_8 = shift;\n"
" my $test_data_16 = shift;\n"
" my $error_count = 0;\n"
" my $fail_count = 0;\n"
" my $pass_count = 0;\n"
+ " # print STDERR \"AddressIncUnitTest: \", 1+$#{$test_data_8}, \" tests\\n\";\n"
+ "\n"
+ " # First a few 8-nibble addresses. Note that this implementation uses\n"
+ " # plain old arithmetic, so a quick sanity check along with verifying what\n"
+ " # happens to overflow (we want it to wrap):\n"
" $address_length = 8;\n"
" foreach my $row (@{$test_data_8}) {\n"
" if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
@@ -3467,6 +5434,8 @@ const char* pprof_perl() {
" $error_count = $fail_count;\n"
" $fail_count = 0;\n"
" $pass_count = 0;\n"
+ "\n"
+ " # Now 16-nibble addresses.\n"
" $address_length = 16;\n"
" foreach my $row (@{$test_data_16}) {\n"
" if ($main::opt_debug and $main::opt_test) { print STDERR \"@{$row}\\n\"; }\n"
@@ -3482,10 +5451,17 @@ const char* pprof_perl() {
" printf STDERR \"AddressInc 64-bit tests: %d passes, %d failures\\n\",\n"
" $pass_count, $fail_count;\n"
" $error_count += $fail_count;\n"
+ "\n"
" return $error_count;\n"
"}\n"
+ "\n"
+ "\n"
+ "# Driver for unit tests.\n"
+ "# Currently just the address add/subtract/increment routines for 64-bit.\n"
"sub RunUnitTests {\n"
" my $error_count = 0;\n"
+ "\n"
+ " # This is a list of tuples [a, b, a+b, a-b, a+1]\n"
" my $unit_test_data_8 = [\n"
" [qw(aaaaaaaa 50505050 fafafafa 5a5a5a5a aaaaaaab)],\n"
" [qw(50505050 aaaaaaaa fafafafa a5a5a5a6 50505051)],\n"
@@ -3494,6 +5470,8 @@ const char* pprof_perl() {
" [qw(00000001 fffffff0 fffffff1 00000011 00000002)],\n"
" ];\n"
" my $unit_test_data_16 = [\n"
+ " # The implementation handles data in 7-nibble chunks, so those are the\n"
+ " # interesting boundaries.\n"
" [qw(aaaaaaaa 50505050\n"
" 00_000000f_afafafa 00_0000005_a5a5a5a 00_000000a_aaaaaab)],\n"
" [qw(50505050 aaaaaaaa\n"
@@ -3504,6 +5482,7 @@ const char* pprof_perl() {
" 00_0000010_0000000 ff_ffffff0_0000002 00_0000000_0000002)],\n"
" [qw(00000001 fffffff0\n"
" 00_000000f_ffffff1 ff_ffffff0_0000011 00_0000000_0000002)],\n"
+ "\n"
" [qw(00_a00000a_aaaaaaa 50505050\n"
" 00_a00000f_afafafa 00_a000005_a5a5a5a 00_a00000a_aaaaaab)],\n"
" [qw(0f_fff0005_0505050 aaaaaaaa\n"
@@ -3515,6 +5494,7 @@ const char* pprof_perl() {
" [qw(00_0000000_0000001 ff_fffffff_ffffff0\n"
" ff_fffffff_ffffff1 00_0000000_0000011 00_0000000_0000002)],\n"
" ];\n"
+ "\n"
" $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16);\n"
" $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16);\n"
" $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16);\n"
---------------------------------------------------------------------
To unsubscribe, e-mail: dev-unsubscribe@brpc.apache.org
For additional commands, e-mail: dev-help@brpc.apache.org