The Tor Browser / file revision

 #! /usr/bin/env perl

 # Copyright (c) 1998-2007, Google Inc.

 # All rights reserved.

 # 

 # Redistribution and use in source and binary forms, with or without

 # modification, are permitted provided that the following conditions are

 # met:

 # 

 #     * Redistributions of source code must retain the above copyright

 # notice, this list of conditions and the following disclaimer.

 #     * Redistributions in binary form must reproduce the above

 # copyright notice, this list of conditions and the following disclaimer

 # in the documentation and/or other materials provided with the

 # distribution.

 #     * Neither the name of Google Inc. nor the names of its

 # contributors may be used to endorse or promote products derived from

 # this software without specific prior written permission.

 # 

 # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS

 # "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT

 # LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR

 # A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT

 # OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,

 # SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT

 # LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,

 # DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY

 # THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT

 # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE

 # OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 # ---

 # Program for printing the profile generated by common/profiler.cc,

 # or by the heap profiler (common/debugallocation.cc)

 #

 # The profile contains a sequence of entries of the form:

 #       <count> <stack trace>

 # This program parses the profile, and generates user-readable

 # output.

 #

 # Examples:

 #

 # % tools/pprof "program" "profile"

 #   Enters "interactive" mode

 #

 # % tools/pprof --text "program" "profile"

 #   Generates one line per procedure

 #

 # % tools/pprof --gv "program" "profile"

 #   Generates annotated call-graph and displays via "gv"

 #

 # % tools/pprof --gv --focus=Mutex "program" "profile"

 #   Restrict to code paths that involve an entry that matches "Mutex"

 #

 # % tools/pprof --gv --focus=Mutex --ignore=string "program" "profile"

 #   Restrict to code paths that involve an entry that matches "Mutex"

 #   and does not match "string"

 #

 # % tools/pprof --list=IBF_CheckDocid "program" "profile"

 #   Generates disassembly listing of all routines with at least one

 #   sample that match the --list=<regexp> pattern.  The listing is

 #   annotated with the flat and cumulative sample counts at each line.

 #

 # % tools/pprof --disasm=IBF_CheckDocid "program" "profile"

 #   Generates disassembly listing of all routines with at least one

 #   sample that match the --disasm=<regexp> pattern.  The listing is

 #   annotated with the flat and cumulative sample counts at each PC value.

 #

 # TODO: Use color to indicate files?

 use strict;

 use warnings;

 use Getopt::Long;

 my $PPROF_VERSION = "2.0";

 # These are the object tools we use which can come from a

 # user-specified location using --tools, from the PPROF_TOOLS

 # environment variable, or from the environment.

 my %obj_tool_map = (

   "objdump" => "objdump",

   "nm" => "nm",

   "addr2line" => "addr2line",

   "c++filt" => "c++filt",

   ## ConfigureObjTools may add architecture-specific entries:

   #"nm_pdb" => "nm-pdb",       # for reading windows (PDB-format) executables

   #"addr2line_pdb" => "addr2line-pdb",                                # ditto

   #"otool" => "otool",         # equivalent of objdump on OS X

 );

 # NOTE: these are lists, so you can put in commandline flags if you want.

 my @DOT = ("dot");          # leave non-absolute, since it may be in /usr/local

 my @GV = ("gv");

 my @EVINCE = ("evince");    # could also be xpdf or perhaps acroread

 my @KCACHEGRIND = ("kcachegrind");

 my @PS2PDF = ("ps2pdf");

 # These are used for dynamic profiles

 my @URL_FETCHER = ("curl", "-s");

 # These are the web pages that servers need to support for dynamic profiles

 my $HEAP_PAGE = "/pprof/heap";

 my $PROFILE_PAGE = "/pprof/profile";   # must support cgi-param "?seconds=#"

 my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param

                                                 # ?seconds=#&event=x&period=n

 my $GROWTH_PAGE = "/pprof/growth";

 my $CONTENTION_PAGE = "/pprof/contention";

 my $WALL_PAGE = "/pprof/wall(?:\\?.*)?";  # accepts options like namefilter

 my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?";

 my $CENSUSPROFILE_PAGE = "/pprof/censusprofile(?:\\?.*)?"; # must support cgi-param

                                                        # "?seconds=#",

                                                        # "?tags_regexp=#" and

                                                        # "?type=#".

 my $SYMBOL_PAGE = "/pprof/symbol";     # must support symbol lookup via POST

 my $PROGRAM_NAME_PAGE = "/pprof/cmdline";

 # These are the web pages that can be named on the command line.

 # All the alternatives must begin with /.

 my $PROFILES = "($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|" .

                "$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|" .

                "$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)";

 # default binary name

 my $UNKNOWN_BINARY = "(unknown)";

 # There is a pervasive dependency on the length (in hex characters,

 # i.e., nibbles) of an address, distinguishing between 32-bit and

 # 64-bit profiles.  To err on the safe size, default to 64-bit here:

 my $address_length = 16;

 my $dev_null = "/dev/null";

 if (! -e $dev_null && $^O =~ /MSWin/) {    # $^O is the OS perl was built for

   $dev_null = "nul";

 }

 # A list of paths to search for shared object files

 my @prefix_list = ();

 # Special routine name that should not have any symbols.

 # Used as separator to parse "addr2line -i" output.

 my $sep_symbol = '_fini';

 my $sep_address = undef;

 ##### Argument parsing #####

 sub usage_string {

   return <<EOF;

 Usage:

 pprof [options] <program> <profiles>

    <profiles> is a space separated list of profile names.

 pprof [options] <symbolized-profiles>

    <symbolized-profiles> is a list of profile files where each file contains

    the necessary symbol mappings  as well as profile data (likely generated

    with --raw).

 pprof [options] <profile>

    <profile> is a remote form.  Symbols are obtained from host:port$SYMBOL_PAGE

    Each name can be:

    /path/to/profile        - a path to a profile file

    host:port[/<service>]   - a location of a service to get profile from

    The /<service> can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile,

                          $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall,

                          $CENSUSPROFILE_PAGE, or /pprof/filteredprofile.

    For instance:

      pprof http://myserver.com:80$HEAP_PAGE

    If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling).

 pprof --symbols <program>

    Maps addresses to symbol names.  In this mode, stdin should be a

    list of library mappings, in the same format as is found in the heap-

    and cpu-profile files (this loosely matches that of /proc/self/maps

    on linux), followed by a list of hex addresses to map, one per line.

    For more help with querying remote servers, including how to add the

    necessary server-side support code, see this filename (or one like it):

    /usr/doc/gperftools-$PPROF_VERSION/pprof_remote_servers.html

 Options:

    --cum               Sort by cumulative data

    --base=<base>       Subtract <base> from <profile> before display

    --interactive       Run in interactive mode (interactive "help" gives help) [default]

    --seconds=<n>       Length of time for dynamic profiles [default=30 secs]

    --add_lib=<file>    Read additional symbols and line info from the given library

    --lib_prefix=<dir>  Comma separated list of library path prefixes

 Reporting Granularity:

    --addresses         Report at address level

    --lines             Report at source line level

    --functions         Report at function level [default]

    --files             Report at source file level

 Output type:

    --text              Generate text report

    --callgrind         Generate callgrind format to stdout

    --gv                Generate Postscript and display

    --evince            Generate PDF and display

    --web               Generate SVG and display

    --list=<regexp>     Generate source listing of matching routines

    --disasm=<regexp>   Generate disassembly of matching routines

    --symbols           Print demangled symbol names found at given addresses

    --dot               Generate DOT file to stdout

    --ps                Generate Postcript to stdout

    --pdf               Generate PDF to stdout

    --svg               Generate SVG to stdout

    --gif               Generate GIF to stdout

    --raw               Generate symbolized pprof data (useful with remote fetch)

 Heap-Profile Options:

    --inuse_space       Display in-use (mega)bytes [default]

    --inuse_objects     Display in-use objects

    --alloc_space       Display allocated (mega)bytes

    --alloc_objects     Display allocated objects

    --show_bytes        Display space in bytes

    --drop_negative     Ignore negative differences

 Contention-profile options:

    --total_delay       Display total delay at each region [default]

    --contentions       Display number of delays at each region

    --mean_delay        Display mean delay at each region

 Call-graph Options:

    --nodecount=<n>     Show at most so many nodes [default=80]

    --nodefraction=<f>  Hide nodes below <f>*total [default=.005]

    --edgefraction=<f>  Hide edges below <f>*total [default=.001]

    --maxdegree=<n>     Max incoming/outgoing edges per node [default=8]

    --focus=<regexp>    Focus on nodes matching <regexp>

    --ignore=<regexp>   Ignore nodes matching <regexp>

    --scale=<n>         Set GV scaling [default=0]

    --heapcheck         Make nodes with non-0 object counts

                        (i.e. direct leak generators) more visible

 Miscellaneous:

    --tools=<prefix or binary:fullpath>[,...]   \$PATH for object tool pathnames

    --test              Run unit tests

    --help              This message

    --version           Version information

 Environment Variables:

    PPROF_TMPDIR        Profiles directory. Defaults to \$HOME/pprof

    PPROF_TOOLS         Prefix for object tools pathnames

 Examples:

 pprof /bin/ls ls.prof

                        Enters "interactive" mode

 pprof --text /bin/ls ls.prof

                        Outputs one line per procedure

 pprof --web /bin/ls ls.prof

                        Displays annotated call-graph in web browser

 pprof --gv /bin/ls ls.prof

                        Displays annotated call-graph via 'gv'

 pprof --gv --focus=Mutex /bin/ls ls.prof

                        Restricts to code paths including a .*Mutex.* entry

 pprof --gv --focus=Mutex --ignore=string /bin/ls ls.prof

                        Code paths including Mutex but not string

 pprof --list=getdir /bin/ls ls.prof

                        (Per-line) annotated source listing for getdir()

 pprof --disasm=getdir /bin/ls ls.prof

                        (Per-PC) annotated disassembly for getdir()

 pprof http://localhost:1234/

                        Enters "interactive" mode

 pprof --text localhost:1234

                        Outputs one line per procedure for localhost:1234

 pprof --raw localhost:1234 > ./local.raw

 pprof --text ./local.raw

                        Fetches a remote profile for later analysis and then

                        analyzes it in text mode.

 EOF

 }

 sub version_string {

   return <<EOF

 pprof (part of gperftools $PPROF_VERSION)

 Copyright 1998-2007 Google Inc.

 This is BSD licensed software; see the source for copying conditions

 and license information.

 There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A

 PARTICULAR PURPOSE.

 EOF

 }

 sub usage {

   my $msg = shift;

   print STDERR "$msg\n\n";

   print STDERR usage_string();

   print STDERR "\nFATAL ERROR: $msg\n";    # just as a reminder

   exit(1);

 }

 sub Init() {

   # Setup tmp-file name and handler to clean it up.

   # We do this in the very beginning so that we can use

   # error() and cleanup() function anytime here after.

   $main::tmpfile_sym = "/tmp/pprof$$.sym";

   $main::tmpfile_ps = "/tmp/pprof$$";

   $main::next_tmpfile = 0;

   $SIG{'INT'} = \&sighandler;

   # Cache from filename/linenumber to source code

   $main::source_cache = ();

   $main::opt_help = 0;

   $main::opt_version = 0;

   $main::opt_cum = 0;

   $main::opt_base = '';

   $main::opt_addresses = 0;

   $main::opt_lines = 0;

   $main::opt_functions = 0;

   $main::opt_files = 0;

   $main::opt_lib_prefix = "";

   $main::opt_text = 0;

   $main::opt_callgrind = 0;

   $main::opt_list = "";

   $main::opt_disasm = "";

   $main::opt_symbols = 0;

   $main::opt_gv = 0;

   $main::opt_evince = 0;

   $main::opt_web = 0;

   $main::opt_dot = 0;

   $main::opt_ps = 0;

   $main::opt_pdf = 0;

   $main::opt_gif = 0;

   $main::opt_svg = 0;

   $main::opt_raw = 0;

   $main::opt_nodecount = 80;

   $main::opt_nodefraction = 0.005;

   $main::opt_edgefraction = 0.001;

   $main::opt_maxdegree = 8;

   $main::opt_focus = '';

   $main::opt_ignore = '';

   $main::opt_scale = 0;

   $main::opt_heapcheck = 0;

   $main::opt_seconds = 30;

   $main::opt_lib = "";

   $main::opt_inuse_space   = 0;

   $main::opt_inuse_objects = 0;

   $main::opt_alloc_space   = 0;

   $main::opt_alloc_objects = 0;

   $main::opt_show_bytes    = 0;

   $main::opt_drop_negative = 0;

   $main::opt_interactive   = 0;

   $main::opt_total_delay = 0;

   $main::opt_contentions = 0;

   $main::opt_mean_delay = 0;

   $main::opt_tools   = "";

   $main::opt_debug   = 0;

   $main::opt_test    = 0;

   # These are undocumented flags used only by unittests.

   $main::opt_test_stride = 0;

   # Are we using $SYMBOL_PAGE?

   $main::use_symbol_page = 0;

   # Files returned by TempName.

   %main::tempnames = ();

   # Type of profile we are dealing with

   # Supported types:

   #     cpu

   #     heap

   #     growth

   #     contention

   $main::profile_type = '';     # Empty type means "unknown"

   GetOptions("help!"          => \$main::opt_help,

              "version!"       => \$main::opt_version,

              "cum!"           => \$main::opt_cum,

              "base=s"         => \$main::opt_base,

              "seconds=i"      => \$main::opt_seconds,

              "add_lib=s"      => \$main::opt_lib,

              "lib_prefix=s"   => \$main::opt_lib_prefix,

              "functions!"     => \$main::opt_functions,

              "lines!"         => \$main::opt_lines,

              "addresses!"     => \$main::opt_addresses,

              "files!"         => \$main::opt_files,

              "text!"          => \$main::opt_text,

              "callgrind!"     => \$main::opt_callgrind,

              "list=s"         => \$main::opt_list,

              "disasm=s"       => \$main::opt_disasm,

              "symbols!"       => \$main::opt_symbols,

              "gv!"            => \$main::opt_gv,

              "evince!"        => \$main::opt_evince,

              "web!"           => \$main::opt_web,

              "dot!"           => \$main::opt_dot,

              "ps!"            => \$main::opt_ps,

              "pdf!"           => \$main::opt_pdf,

              "svg!"           => \$main::opt_svg,

              "gif!"           => \$main::opt_gif,

              "raw!"           => \$main::opt_raw,

              "interactive!"   => \$main::opt_interactive,

              "nodecount=i"    => \$main::opt_nodecount,

              "nodefraction=f" => \$main::opt_nodefraction,

              "edgefraction=f" => \$main::opt_edgefraction,

              "maxdegree=i"    => \$main::opt_maxdegree,

              "focus=s"        => \$main::opt_focus,

              "ignore=s"       => \$main::opt_ignore,

              "scale=i"        => \$main::opt_scale,

              "heapcheck"      => \$main::opt_heapcheck,

              "inuse_space!"   => \$main::opt_inuse_space,

              "inuse_objects!" => \$main::opt_inuse_objects,

              "alloc_space!"   => \$main::opt_alloc_space,

              "alloc_objects!" => \$main::opt_alloc_objects,

              "show_bytes!"    => \$main::opt_show_bytes,

              "drop_negative!" => \$main::opt_drop_negative,

              "total_delay!"   => \$main::opt_total_delay,

              "contentions!"   => \$main::opt_contentions,

              "mean_delay!"    => \$main::opt_mean_delay,

              "tools=s"        => \$main::opt_tools,

              "test!"          => \$main::opt_test,

              "debug!"         => \$main::opt_debug,

              # Undocumented flags used only by unittests:

              "test_stride=i"  => \$main::opt_test_stride,

       ) || usage("Invalid option(s)");

   # Deal with the standard --help and --version

   if ($main::opt_help) {

     print usage_string();

     exit(0);

   }

   if ($main::opt_version) {

     print version_string();

     exit(0);

   }

   # Disassembly/listing/symbols mode requires address-level info

   if ($main::opt_disasm || $main::opt_list || $main::opt_symbols) {

     $main::opt_functions = 0;

     $main::opt_lines = 0;

     $main::opt_addresses = 1;

     $main::opt_files = 0;

   }

   # Check heap-profiling flags

   if ($main::opt_inuse_space +

       $main::opt_inuse_objects +

       $main::opt_alloc_space +

       $main::opt_alloc_objects > 1) {

     usage("Specify at most on of --inuse/--alloc options");

   }

   # Check output granularities

   my $grains =

       $main::opt_functions +

       $main::opt_lines +

       $main::opt_addresses +

       $main::opt_files +

       0;

   if ($grains > 1) {

     usage("Only specify one output granularity option");

   }

   if ($grains == 0) {

     $main::opt_functions = 1;

   }

   # Check output modes

   my $modes =

       $main::opt_text +

       $main::opt_callgrind +

       ($main::opt_list eq '' ? 0 : 1) +

       ($main::opt_disasm eq '' ? 0 : 1) +

       ($main::opt_symbols == 0 ? 0 : 1) +

       $main::opt_gv +

       $main::opt_evince +

       $main::opt_web +

       $main::opt_dot +

       $main::opt_ps +

       $main::opt_pdf +

       $main::opt_svg +

       $main::opt_gif +

       $main::opt_raw +

       $main::opt_interactive +

       0;

   if ($modes > 1) {

     usage("Only specify one output mode");

   }

   if ($modes == 0) {

     if (-t STDOUT) {  # If STDOUT is a tty, activate interactive mode

       $main::opt_interactive = 1;

     } else {

       $main::opt_text = 1;

     }

   }

   if ($main::opt_test) {

     RunUnitTests();

     # Should not return

     exit(1);

   }

   # Binary name and profile arguments list

   $main::prog = "";

   @main::pfile_args = ();

   # Remote profiling without a binary (using $SYMBOL_PAGE instead)

   if (@ARGV > 0) {

     if (IsProfileURL($ARGV[0])) {

       $main::use_symbol_page = 1;

     } elsif (IsSymbolizedProfileFile($ARGV[0])) {

       $main::use_symbolized_profile = 1;

       $main::prog = $UNKNOWN_BINARY;  # will be set later from the profile file

     }

   }

   if ($main::use_symbol_page || $main::use_symbolized_profile) {

     # We don't need a binary!

     my %disabled = ('--lines' => $main::opt_lines,

                     '--disasm' => $main::opt_disasm);

     for my $option (keys %disabled) {

       usage("$option cannot be used without a binary") if $disabled{$option};

     }

     # Set $main::prog later...

     scalar(@ARGV) || usage("Did not specify profile file");

   } elsif ($main::opt_symbols) {

     # --symbols needs a binary-name (to run nm on, etc) but not profiles

     $main::prog = shift(@ARGV) || usage("Did not specify program");

   } else {

     $main::prog = shift(@ARGV) || usage("Did not specify program");

     scalar(@ARGV) || usage("Did not specify profile file");

   }

   # Parse profile file/location arguments

   foreach my $farg (@ARGV) {

     if ($farg =~ m/(.*)\@([0-9]+)(|\/.*)$/ ) {

       my $machine = $1;

       my $num_machines = $2;

       my $path = $3;

       for (my $i = 0; $i < $num_machines; $i++) {

         unshift(@main::pfile_args, "$i.$machine$path");

       }

     } else {

       unshift(@main::pfile_args, $farg);

     }

   }

   if ($main::use_symbol_page) {

     unless (IsProfileURL($main::pfile_args[0])) {

       error("The first profile should be a remote form to use $SYMBOL_PAGE\n");

     }

     CheckSymbolPage();

     $main::prog = FetchProgramName();

   } elsif (!$main::use_symbolized_profile) {  # may not need objtools!

     ConfigureObjTools($main::prog)

   }

   # Break the opt_lib_prefix into the prefix_list array

   @prefix_list = split (',', $main::opt_lib_prefix);

   # Remove trailing / from the prefixes, in the list to prevent

   # searching things like /my/path//lib/mylib.so

   foreach (@prefix_list) {

     s|/+$||;

   }

 }

 sub Main() {

   Init();

   $main::collected_profile = undef;

   @main::profile_files = ();

   $main::op_time = time();

   # Printing symbols is special and requires a lot less info that most.

   if ($main::opt_symbols) {

     PrintSymbols(*STDIN);   # Get /proc/maps and symbols output from stdin

     return;

   }

   # Fetch all profile data

   FetchDynamicProfiles();

   # this will hold symbols that we read from the profile files

   my $symbol_map = {};

   # Read one profile, pick the last item on the list

   my $data = ReadProfile($main::prog, pop(@main::profile_files));

   my $profile = $data->{profile};

   my $pcs = $data->{pcs};

   my $libs = $data->{libs};   # Info about main program and shared libraries

   $symbol_map = MergeSymbols($symbol_map, $data->{symbols});

   # Add additional profiles, if available.

   if (scalar(@main::profile_files) > 0) {

     foreach my $pname (@main::profile_files) {

       my $data2 = ReadProfile($main::prog, $pname);

       $profile = AddProfile($profile, $data2->{profile});

       $pcs = AddPcs($pcs, $data2->{pcs});

       $symbol_map = MergeSymbols($symbol_map, $data2->{symbols});

     }

   }

   # Subtract base from profile, if specified

   if ($main::opt_base ne '') {

     my $base = ReadProfile($main::prog, $main::opt_base);

     $profile = SubtractProfile($profile, $base->{profile});

     $pcs = AddPcs($pcs, $base->{pcs});

     $symbol_map = MergeSymbols($symbol_map, $base->{symbols});

   }

   # Get total data in profile

   my $total = TotalProfile($profile);

   # Collect symbols

   my $symbols;

   if ($main::use_symbolized_profile) {

     $symbols = FetchSymbols($pcs, $symbol_map);

   } elsif ($main::use_symbol_page) {

     $symbols = FetchSymbols($pcs);

   } else {

     # TODO(csilvers): $libs uses the /proc/self/maps data from profile1,

     # which may differ from the data from subsequent profiles, especially

     # if they were run on different machines.  Use appropriate libs for

     # each pc somehow.

     $symbols = ExtractSymbols($libs, $pcs);

   }

   # Remove uniniteresting stack items

   $profile = RemoveUninterestingFrames($symbols, $profile);

   # Focus?

   if ($main::opt_focus ne '') {

     $profile = FocusProfile($symbols, $profile, $main::opt_focus);

   }

   # Ignore?

   if ($main::opt_ignore ne '') {

     $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore);

   }

   my $calls = ExtractCalls($symbols, $profile);

   # Reduce profiles to required output granularity, and also clean

   # each stack trace so a given entry exists at most once.

   my $reduced = ReduceProfile($symbols, $profile);

   # Get derived profiles

   my $flat = FlatProfile($reduced);

   my $cumulative = CumulativeProfile($reduced);

   # Print

   if (!$main::opt_interactive) {

     if ($main::opt_disasm) {

       PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm);

     } elsif ($main::opt_list) {

       PrintListing($total, $libs, $flat, $cumulative, $main::opt_list, 0);

     } elsif ($main::opt_text) {

       # Make sure the output is empty when have nothing to report

       # (only matters when --heapcheck is given but we must be

       # compatible with old branches that did not pass --heapcheck always):

       if ($total != 0) {

         printf("Total: %s %s\n", Unparse($total), Units());

       }

       PrintText($symbols, $flat, $cumulative, -1);

     } elsif ($main::opt_raw) {

       PrintSymbolizedProfile($symbols, $profile, $main::prog);

     } elsif ($main::opt_callgrind) {

       PrintCallgrind($calls);

     } else {

       if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {

         if ($main::opt_gv) {

           RunGV(TempName($main::next_tmpfile, "ps"), "");

         } elsif ($main::opt_evince) {

           RunEvince(TempName($main::next_tmpfile, "pdf"), "");

         } elsif ($main::opt_web) {

           my $tmp = TempName($main::next_tmpfile, "svg");

           RunWeb($tmp);

           # The command we run might hand the file name off

           # to an already running browser instance and then exit.

           # Normally, we'd remove $tmp on exit (right now),

           # but fork a child to remove $tmp a little later, so that the

           # browser has time to load it first.

           delete $main::tempnames{$tmp};

           if (fork() == 0) {

             sleep 5;

             unlink($tmp);

             exit(0);

           }

         }

       } else {

         cleanup();

         exit(1);

       }

     }

   } else {

     InteractiveMode($profile, $symbols, $libs, $total);

   }

   cleanup();

   exit(0);

 }

 ##### Entry Point #####

 Main();

 # Temporary code to detect if we're running on a Goobuntu system.

 # These systems don't have the right stuff installed for the special

 # Readline libraries to work, so as a temporary workaround, we default

 # to using the normal stdio code, rather than the fancier readline-based

 # code

 sub ReadlineMightFail {

   if (-e '/lib/libtermcap.so.2') {

     return 0;  # libtermcap exists, so readline should be okay

   } else {

     return 1;

   }

 }

 sub RunGV {

   my $fname = shift;

   my $bg = shift;       # "" or " &" if we should run in background

   if (!system(ShellEscape(@GV, "--version") . " >$dev_null 2>&1")) {

     # Options using double dash are supported by this gv version.

     # Also, turn on noantialias to better handle bug in gv for

     # postscript files with large dimensions.

     # TODO: Maybe we should not pass the --noantialias flag

     # if the gv version is known to work properly without the flag.

     system(ShellEscape(@GV, "--scale=$main::opt_scale", "--noantialias", $fname)

            . $bg);

   } else {

     # Old gv version - only supports options that use single dash.

     print STDERR ShellEscape(@GV, "-scale", $main::opt_scale) . "\n";

     system(ShellEscape(@GV, "-scale", "$main::opt_scale", $fname) . $bg);

   }

 }

 sub RunEvince {

   my $fname = shift;

   my $bg = shift;       # "" or " &" if we should run in background

   system(ShellEscape(@EVINCE, $fname) . $bg);

 }

 sub RunWeb {

   my $fname = shift;

   print STDERR "Loading web page file:///$fname\n";

   if (`uname` =~ /Darwin/) {

     # OS X: open will use standard preference for SVG files.

     system("/usr/bin/open", $fname);

     return;

   }

   # Some kind of Unix; try generic symlinks, then specific browsers.

   # (Stop once we find one.)

   # Works best if the browser is already running.

   my @alt = (

     "/etc/alternatives/gnome-www-browser",

     "/etc/alternatives/x-www-browser",

     "google-chrome",

     "firefox",

   );

   foreach my $b (@alt) {

     if (system($b, $fname) == 0) {

       return;

     }

   }

   print STDERR "Could not load web browser.\n";

 }

 sub RunKcachegrind {

   my $fname = shift;

   my $bg = shift;       # "" or " &" if we should run in background

   print STDERR "Starting '@KCACHEGRIND " . $fname . $bg . "'\n";

   system(ShellEscape(@KCACHEGRIND, $fname) . $bg);

 }

 ##### Interactive helper routines #####

 sub InteractiveMode {

   $| = 1;  # Make output unbuffered for interactive mode

   my ($orig_profile, $symbols, $libs, $total) = @_;

   print STDERR "Welcome to pprof!  For help, type 'help'.\n";

   # Use ReadLine if it's installed and input comes from a console.

   if ( -t STDIN &&

        !ReadlineMightFail() &&

        defined(eval {require Term::ReadLine}) ) {

     my $term = new Term::ReadLine 'pprof';

     while ( defined ($_ = $term->readline('(pprof) '))) {

       $term->addhistory($_) if /\S/;

       if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {

         last;    # exit when we get an interactive command to quit

       }

     }

   } else {       # don't have readline

     while (1) {

       print STDERR "(pprof) ";

       $_ = <STDIN>;

       last if ! defined $_ ;

       s/\r//g;         # turn windows-looking lines into unix-looking lines

       # Save some flags that might be reset by InteractiveCommand()

       my $save_opt_lines = $main::opt_lines;

       if (!InteractiveCommand($orig_profile, $symbols, $libs, $total, $_)) {

         last;    # exit when we get an interactive command to quit

       }

       # Restore flags

       $main::opt_lines = $save_opt_lines;

     }

   }

 }

 # Takes two args: orig profile, and command to run.

 # Returns 1 if we should keep going, or 0 if we were asked to quit

 sub InteractiveCommand {

   my($orig_profile, $symbols, $libs, $total, $command) = @_;

   $_ = $command;                # just to make future m//'s easier

   if (!defined($_)) {

     print STDERR "\n";

     return 0;

   }

   if (m/^\s*quit/) {

     return 0;

   }

   if (m/^\s*help/) {

     InteractiveHelpMessage();

     return 1;

   }

   # Clear all the mode options -- mode is controlled by "$command"

   $main::opt_text = 0;

   $main::opt_callgrind = 0;

   $main::opt_disasm = 0;

   $main::opt_list = 0;

   $main::opt_gv = 0;

   $main::opt_evince = 0;

   $main::opt_cum = 0;

   if (m/^\s*(text|top)(\d*)\s*(.*)/) {

     $main::opt_text = 1;

     my $line_limit = ($2 ne "") ? int($2) : 10;

     my $routine;

     my $ignore;

     ($routine, $ignore) = ParseInteractiveArgs($3);

     my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);

     my $reduced = ReduceProfile($symbols, $profile);

     # Get derived profiles

     my $flat = FlatProfile($reduced);

     my $cumulative = CumulativeProfile($reduced);

     PrintText($symbols, $flat, $cumulative, $line_limit);

     return 1;

   }

   if (m/^\s*callgrind\s*([^ \n]*)/) {

     $main::opt_callgrind = 1;

     # Get derived profiles

     my $calls = ExtractCalls($symbols, $orig_profile);

     my $filename = $1;

     if ( $1 eq '' ) {

       $filename = TempName($main::next_tmpfile, "callgrind");

     }

     PrintCallgrind($calls, $filename);

     if ( $1 eq '' ) {

       RunKcachegrind($filename, " & ");

       $main::next_tmpfile++;

     }

     return 1;

   }

   if (m/^\s*(web)?list\s*(.+)/) {

     my $html = (defined($1) && ($1 eq "web"));

     $main::opt_list = 1;

     my $routine;

     my $ignore;

     ($routine, $ignore) = ParseInteractiveArgs($2);

     my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);

     my $reduced = ReduceProfile($symbols, $profile);

     # Get derived profiles

     my $flat = FlatProfile($reduced);

     my $cumulative = CumulativeProfile($reduced);

     PrintListing($total, $libs, $flat, $cumulative, $routine, $html);

     return 1;

   }

   if (m/^\s*disasm\s*(.+)/) {

     $main::opt_disasm = 1;

     my $routine;

     my $ignore;

     ($routine, $ignore) = ParseInteractiveArgs($1);

     # Process current profile to account for various settings

     my $profile = ProcessProfile($total, $orig_profile, $symbols, "", $ignore);

     my $reduced = ReduceProfile($symbols, $profile);

     # Get derived profiles

     my $flat = FlatProfile($reduced);

     my $cumulative = CumulativeProfile($reduced);

     PrintDisassembly($libs, $flat, $cumulative, $routine);

     return 1;

   }

   if (m/^\s*(gv|web|evince)\s*(.*)/) {

     $main::opt_gv = 0;

     $main::opt_evince = 0;

     $main::opt_web = 0;

     if ($1 eq "gv") {

       $main::opt_gv = 1;

     } elsif ($1 eq "evince") {

       $main::opt_evince = 1;

     } elsif ($1 eq "web") {

       $main::opt_web = 1;

     }

     my $focus;

     my $ignore;

     ($focus, $ignore) = ParseInteractiveArgs($2);

     # Process current profile to account for various settings

     my $profile = ProcessProfile($total, $orig_profile, $symbols,

                                  $focus, $ignore);

     my $reduced = ReduceProfile($symbols, $profile);

     # Get derived profiles

     my $flat = FlatProfile($reduced);

     my $cumulative = CumulativeProfile($reduced);

     if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {

       if ($main::opt_gv) {

         RunGV(TempName($main::next_tmpfile, "ps"), " &");

       } elsif ($main::opt_evince) {

         RunEvince(TempName($main::next_tmpfile, "pdf"), " &");

       } elsif ($main::opt_web) {

         RunWeb(TempName($main::next_tmpfile, "svg"));

       }

       $main::next_tmpfile++;

     }

     return 1;

   }

   if (m/^\s*$/) {

     return 1;

   }

   print STDERR "Unknown command: try 'help'.\n";

   return 1;

 }

 sub ProcessProfile {

   my $total_count = shift;

   my $orig_profile = shift;

   my $symbols = shift;

   my $focus = shift;

   my $ignore = shift;

   # Process current profile to account for various settings

   my $profile = $orig_profile;

   printf("Total: %s %s\n", Unparse($total_count), Units());

   if ($focus ne '') {

     $profile = FocusProfile($symbols, $profile, $focus);

     my $focus_count = TotalProfile($profile);

     printf("After focusing on '%s': %s %s of %s (%0.1f%%)\n",

            $focus,

            Unparse($focus_count), Units(),

            Unparse($total_count), ($focus_count*100.0) / $total_count);

   }

   if ($ignore ne '') {

     $profile = IgnoreProfile($symbols, $profile, $ignore);

     my $ignore_count = TotalProfile($profile);

     printf("After ignoring '%s': %s %s of %s (%0.1f%%)\n",

            $ignore,

            Unparse($ignore_count), Units(),

            Unparse($total_count),

            ($ignore_count*100.0) / $total_count);

   }

   return $profile;

 }

 sub InteractiveHelpMessage {

   print STDERR <<ENDOFHELP;

 Interactive pprof mode

 Commands:

   gv

   gv [focus] [-ignore1] [-ignore2]

       Show graphical hierarchical display of current profile.  Without

       any arguments, shows all samples in the profile.  With the optional

       "focus" argument, restricts the samples shown to just those where

       the "focus" regular expression matches a routine name on the stack

       trace.

   web

   web [focus] [-ignore1] [-ignore2]

       Like GV, but displays profile in your web browser instead of using

       Ghostview. Works best if your web browser is already running.

       To change the browser that gets used:

       On Linux, set the /etc/alternatives/gnome-www-browser symlink.

       On OS X, change the Finder association for SVG files.

   list [routine_regexp] [-ignore1] [-ignore2]

       Show source listing of routines whose names match "routine_regexp"

   weblist [routine_regexp] [-ignore1] [-ignore2]

      Displays a source listing of routines whose names match "routine_regexp"

      in a web browser.  You can click on source lines to view the

      corresponding disassembly.

   top [--cum] [-ignore1] [-ignore2]

   top20 [--cum] [-ignore1] [-ignore2]

   top37 [--cum] [-ignore1] [-ignore2]

       Show top lines ordered by flat profile count, or cumulative count

       if --cum is specified.  If a number is present after 'top', the

       top K routines will be shown (defaults to showing the top 10)

   disasm [routine_regexp] [-ignore1] [-ignore2]

       Show disassembly of routines whose names match "routine_regexp",

       annotated with sample counts.

   callgrind

   callgrind [filename]

       Generates callgrind file. If no filename is given, kcachegrind is called.

   help - This listing

   quit or ^D - End pprof

 For commands that accept optional -ignore tags, samples where any routine in

 the stack trace matches the regular expression in any of the -ignore

 parameters will be ignored.

 Further pprof details are available at this location (or one similar):

  /usr/doc/gperftools-$PPROF_VERSION/cpu_profiler.html

  /usr/doc/gperftools-$PPROF_VERSION/heap_profiler.html

 ENDOFHELP

 }

 sub ParseInteractiveArgs {

   my $args = shift;

   my $focus = "";

   my $ignore = "";

   my @x = split(/ +/, $args);

   foreach $a (@x) {

     if ($a =~ m/^(--|-)lines$/) {

       $main::opt_lines = 1;

     } elsif ($a =~ m/^(--|-)cum$/) {

       $main::opt_cum = 1;

     } elsif ($a =~ m/^-(.*)/) {

       $ignore .= (($ignore ne "") ? "|" : "" ) . $1;

     } else {

       $focus .= (($focus ne "") ? "|" : "" ) . $a;

     }

   }

   if ($ignore ne "") {

     print STDERR "Ignoring samples in call stacks that match '$ignore'\n";

   }

   return ($focus, $ignore);

 }

 ##### Output code #####

 sub TempName {

   my $fnum = shift;

   my $ext = shift;

   my $file = "$main::tmpfile_ps.$fnum.$ext";

   $main::tempnames{$file} = 1;

   return $file;

 }

 # Print profile data in packed binary format (64-bit) to standard out

 sub PrintProfileData {

   my $profile = shift;

   # print header (64-bit style)

   # (zero) (header-size) (version) (sample-period) (zero)

   print pack('L*', 0, 0, 3, 0, 0, 0, 1, 0, 0, 0);

   foreach my $k (keys(%{$profile})) {

     my $count = $profile->{$k};

     my @addrs = split(/\n/, $k);

     if ($#addrs >= 0) {

       my $depth = $#addrs + 1;

       # int(foo / 2**32) is the only reliable way to get rid of bottom

       # 32 bits on both 32- and 64-bit systems.

       print pack('L*', $count & 0xFFFFFFFF, int($count / 2**32));

       print pack('L*', $depth & 0xFFFFFFFF, int($depth / 2**32));

       foreach my $full_addr (@addrs) {

         my $addr = $full_addr;

         $addr =~ s/0x0*//;  # strip off leading 0x, zeroes

         if (length($addr) > 16) {

           print STDERR "Invalid address in profile: $full_addr\n";

           next;

         }

         my $low_addr = substr($addr, -8);       # get last 8 hex chars

         my $high_addr = substr($addr, -16, 8);  # get up to 8 more hex chars

         print pack('L*', hex('0x' . $low_addr), hex('0x' . $high_addr));

       }

     }

   }

 }

 # Print symbols and profile data

 sub PrintSymbolizedProfile {

   my $symbols = shift;

   my $profile = shift;

   my $prog = shift;

   $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash

   my $symbol_marker = $&;

   print '--- ', $symbol_marker, "\n";

   if (defined($prog)) {

     print 'binary=', $prog, "\n";

   }

   while (my ($pc, $name) = each(%{$symbols})) {

     my $sep = ' ';

     print '0x', $pc;

     # We have a list of function names, which include the inlined

     # calls.  They are separated (and terminated) by --, which is

     # illegal in function names.

     for (my $j = 2; $j <= $#{$name}; $j += 3) {

       print $sep, $name->[$j];

       $sep = '--';

     }

     print "\n";

   }

   print '---', "\n";

   $PROFILE_PAGE =~ m,[^/]+$,;    # matches everything after the last slash

   my $profile_marker = $&;

   print '--- ', $profile_marker, "\n";

   if (defined($main::collected_profile)) {

     # if used with remote fetch, simply dump the collected profile to output.

     open(SRC, "<$main::collected_profile");

     while (<SRC>) {

       print $_;

     }

     close(SRC);

   } else {

     # dump a cpu-format profile to standard out

     PrintProfileData($profile);

   }

 }

 # Print text output

 sub PrintText {

   my $symbols = shift;

   my $flat = shift;

   my $cumulative = shift;

   my $line_limit = shift;

   my $total = TotalProfile($flat);

   # Which profile to sort by?

   my $s = $main::opt_cum ? $cumulative : $flat;

   my $running_sum = 0;

   my $lines = 0;

   foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b }

                  keys(%{$cumulative})) {

     my $f = GetEntry($flat, $k);

     my $c = GetEntry($cumulative, $k);

     $running_sum += $f;

     my $sym = $k;

     if (exists($symbols->{$k})) {

       $sym = $symbols->{$k}->[0] . " " . $symbols->{$k}->[1];

       if ($main::opt_addresses) {

         $sym = $k . " " . $sym;

       }

     }

     if ($f != 0 || $c != 0) {

       printf("%8s %6s %6s %8s %6s %s\n",

              Unparse($f),

              Percent($f, $total),

              Percent($running_sum, $total),

              Unparse($c),

              Percent($c, $total),

              $sym);

     }

     $lines++;

     last if ($line_limit >= 0 && $lines >= $line_limit);

   }

 }

 # Callgrind format has a compression for repeated function and file

 # names.  You show the name the first time, and just use its number

 # subsequently.  This can cut down the file to about a third or a

 # quarter of its uncompressed size.  $key and $val are the key/value

 # pair that would normally be printed by callgrind; $map is a map from

 # value to number.

 sub CompressedCGName {

   my($key, $val, $map) = @_;

   my $idx = $map->{$val};

   # For very short keys, providing an index hurts rather than helps.

   if (length($val) <= 3) {

     return "$key=$val\n";

   } elsif (defined($idx)) {

     return "$key=($idx)\n";

   } else {

     # scalar(keys $map) gives the number of items in the map.

     $idx = scalar(keys(%{$map})) + 1;

     $map->{$val} = $idx;

     return "$key=($idx) $val\n";

   }

 }

 # Print the call graph in a way that's suiteable for callgrind.

 sub PrintCallgrind {

   my $calls = shift;

   my $filename;

   my %filename_to_index_map;

   my %fnname_to_index_map;

   if ($main::opt_interactive) {

     $filename = shift;

     print STDERR "Writing callgrind file to '$filename'.\n"

   } else {

     $filename = "&STDOUT";

   }

   open(CG, ">$filename");

   printf CG ("events: Hits\n\n");

   foreach my $call ( map { $_->[0] }

                      sort { $a->[1] cmp $b ->[1] ||

                             $a->[2] <=> $b->[2] }

                      map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;

                            [$_, $1, $2] }

                      keys %$calls ) {

     my $count = int($calls->{$call});

     $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;

     my ( $caller_file, $caller_line, $caller_function,

          $callee_file, $callee_line, $callee_function ) =

        ( $1, $2, $3, $5, $6, $7 );

     # TODO(csilvers): for better compression, collect all the

     # caller/callee_files and functions first, before printing

     # anything, and only compress those referenced more than once.

     printf CG CompressedCGName("fl", $caller_file, \%filename_to_index_map);

     printf CG CompressedCGName("fn", $caller_function, \%fnname_to_index_map);

     if (defined $6) {

       printf CG CompressedCGName("cfl", $callee_file, \%filename_to_index_map);

       printf CG CompressedCGName("cfn", $callee_function, \%fnname_to_index_map);

       printf CG ("calls=$count $callee_line\n");

     }

     printf CG ("$caller_line $count\n\n");

   }

 }

 # Print disassembly for all all routines that match $main::opt_disasm

 sub PrintDisassembly {

   my $libs = shift;

   my $flat = shift;

   my $cumulative = shift;

   my $disasm_opts = shift;

   my $total = TotalProfile($flat);

   foreach my $lib (@{$libs}) {

     my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts);

     my $offset = AddressSub($lib->[1], $lib->[3]);

     foreach my $routine (sort ByName keys(%{$symbol_table})) {

       my $start_addr = $symbol_table->{$routine}->[0];

       my $end_addr = $symbol_table->{$routine}->[1];

       # See if there are any samples in this routine

       my $length = hex(AddressSub($end_addr, $start_addr));

       my $addr = AddressAdd($start_addr, $offset);

       for (my $i = 0; $i < $length; $i++) {

         if (defined($cumulative->{$addr})) {

           PrintDisassembledFunction($lib->[0], $offset,

                                     $routine, $flat, $cumulative,

                                     $start_addr, $end_addr, $total);

           last;

         }

         $addr = AddressInc($addr);

       }

     }

   }

 }

 # Return reference to array of tuples of the form:

 #       [start_address, filename, linenumber, instruction, limit_address]

 # E.g.,

 #       ["0x806c43d", "/foo/bar.cc", 131, "ret", "0x806c440"]

 sub Disassemble {

   my $prog = shift;

   my $offset = shift;

   my $start_addr = shift;

   my $end_addr = shift;

   my $objdump = $obj_tool_map{"objdump"};

   my $cmd = ShellEscape($objdump, "-C", "-d", "-l", "--no-show-raw-insn",

                         "--start-address=0x$start_addr",

                         "--stop-address=0x$end_addr", $prog);

   open(OBJDUMP, "$cmd |") || error("$cmd: $!\n");

   my @result = ();

   my $filename = "";

   my $linenumber = -1;

   my $last = ["", "", "", ""];

   while (<OBJDUMP>) {

     s/\r//g;         # turn windows-looking lines into unix-looking lines

     chop;

     if (m|\s*([^:\s]+):(\d+)\s*$|) {

       # Location line of the form:

       #   <filename>:<linenumber>

       $filename = $1;

       $linenumber = $2;

     } elsif (m/^ +([0-9a-f]+):\s*(.*)/) {

       # Disassembly line -- zero-extend address to full length

       my $addr = HexExtend($1);

       my $k = AddressAdd($addr, $offset);

       $last->[4] = $k;   # Store ending address for previous instruction

       $last = [$k, $filename, $linenumber, $2, $end_addr];

       push(@result, $last);

     }

   }

   close(OBJDUMP);

   return @result;

 }

 # The input file should contain lines of the form /proc/maps-like

 # output (same format as expected from the profiles) or that looks

 # like hex addresses (like "0xDEADBEEF").  We will parse all

 # /proc/maps output, and for all the hex addresses, we will output

 # "short" symbol names, one per line, in the same order as the input.

 sub PrintSymbols {

   my $maps_and_symbols_file = shift;

   # ParseLibraries expects pcs to be in a set.  Fine by us...

   my @pclist = ();   # pcs in sorted order

   my $pcs = {};

   my $map = "";

   foreach my $line (<$maps_and_symbols_file>) {

     $line =~ s/\r//g;    # turn windows-looking lines into unix-looking lines

     if ($line =~ /\b(0x[0-9a-f]+)\b/i) {

       push(@pclist, HexExtend($1));

       $pcs->{$pclist[-1]} = 1;

     } else {

       $map .= $line;

     }

   }

   my $libs = ParseLibraries($main::prog, $map, $pcs);

   my $symbols = ExtractSymbols($libs, $pcs);

   foreach my $pc (@pclist) {

     # ->[0] is the shortname, ->[2] is the full name

     print(($symbols->{$pc}->[0] || "??") . "\n");

   }

 }

 # For sorting functions by name

 sub ByName {

   return ShortFunctionName($a) cmp ShortFunctionName($b);

 }

 # Print source-listing for all all routines that match $list_opts

 sub PrintListing {

   my $total = shift;

   my $libs = shift;

   my $flat = shift;

   my $cumulative = shift;

   my $list_opts = shift;

   my $html = shift;

   my $output = \*STDOUT;

   my $fname = "";

   if ($html) {

     # Arrange to write the output to a temporary file

     $fname = TempName($main::next_tmpfile, "html");

     $main::next_tmpfile++;

     if (!open(TEMP, ">$fname")) {

       print STDERR "$fname: $!\n";

       return;

     }

     $output = \*TEMP;

     print $output HtmlListingHeader();

     printf $output ("<div class=\"legend\">%s<br>Total: %s %s</div>\n",

                     $main::prog, Unparse($total), Units());

   }

   my $listed = 0;

   foreach my $lib (@{$libs}) {

     my $symbol_table = GetProcedureBoundaries($lib->[0], $list_opts);

     my $offset = AddressSub($lib->[1], $lib->[3]);

     foreach my $routine (sort ByName keys(%{$symbol_table})) {

       # Print if there are any samples in this routine

       my $start_addr = $symbol_table->{$routine}->[0];

       my $end_addr = $symbol_table->{$routine}->[1];

       my $length = hex(AddressSub($end_addr, $start_addr));

       my $addr = AddressAdd($start_addr, $offset);

       for (my $i = 0; $i < $length; $i++) {

         if (defined($cumulative->{$addr})) {

           $listed += PrintSource(

             $lib->[0], $offset,

             $routine, $flat, $cumulative,

             $start_addr, $end_addr,

             $html,

             $output);

           last;

         }

         $addr = AddressInc($addr);

       }

     }

   }

   if ($html) {

     if ($listed > 0) {

       print $output HtmlListingFooter();

       close($output);

       RunWeb($fname);

     } else {

       close($output);

       unlink($fname);

     }

   }

 }

 sub HtmlListingHeader {

   return <<'EOF';

 <DOCTYPE html>

 <html>

 <head>

 <title>Pprof listing</title>

 <style type="text/css">

 body {

   font-family: sans-serif;

 }

 h1 {

   font-size: 1.5em;

   margin-bottom: 4px;

 }

 .legend {

   font-size: 1.25em;

 }

 .line {

   color: #aaaaaa;

 }

 .nop {

   color: #aaaaaa;

 }

 .unimportant {

   color: #cccccc;

 }

 .disasmloc {

   color: #000000;

 }

 .deadsrc {

   cursor: pointer;

 }

 .deadsrc:hover {

   background-color: #eeeeee;

 }

 .livesrc {

   color: #0000ff;

   cursor: pointer;

 }

 .livesrc:hover {

   background-color: #eeeeee;

 }

 .asm {

   color: #008800;

   display: none;

 }

 </style>

 <script type="text/javascript">

 function pprof_toggle_asm(e) {

   var target;

   if (!e) e = window.event;

   if (e.target) target = e.target;

   else if (e.srcElement) target = e.srcElement;

   if (target) {

     var asm = target.nextSibling;

     if (asm && asm.className == "asm") {

       asm.style.display = (asm.style.display == "block" ? "" : "block");

       e.preventDefault();

       return false;

     }

   }

 }

 </script>

 </head>

 <body>

 EOF

 }

 sub HtmlListingFooter {

   return <<'EOF';

 </body>

 </html>

 EOF

 }

 sub HtmlEscape {

   my $text = shift;

   $text =~ s/&/&/g;

   $text =~ s/</&lt;/g;

   $text =~ s/>/>/g;

   return $text;

 }

 # Returns the indentation of the line, if it has any non-whitespace

 # characters.  Otherwise, returns -1.

 sub Indentation {

   my $line = shift;

   if (m/^(\s*)\S/) {

     return length($1);

   } else {

     return -1;

   }

 }

 # If the symbol table contains inlining info, Disassemble() may tag an

 # instruction with a location inside an inlined function.  But for

 # source listings, we prefer to use the location in the function we

 # are listing.  So use MapToSymbols() to fetch full location

 # information for each instruction and then pick out the first

 # location from a location list (location list contains callers before

 # callees in case of inlining).

 #

 # After this routine has run, each entry in $instructions contains:

 #   [0] start address

 #   [1] filename for function we are listing

 #   [2] line number for function we are listing

 #   [3] disassembly

 #   [4] limit address

 #   [5] most specific filename (may be different from [1] due to inlining)

 #   [6] most specific line number (may be different from [2] due to inlining)

 sub GetTopLevelLineNumbers {

   my ($lib, $offset, $instructions) = @_;

   my $pcs = [];

   for (my $i = 0; $i <= $#{$instructions}; $i++) {

     push(@{$pcs}, $instructions->[$i]->[0]);

   }

   my $symbols = {};

   MapToSymbols($lib, $offset, $pcs, $symbols);

   for (my $i = 0; $i <= $#{$instructions}; $i++) {

     my $e = $instructions->[$i];

     push(@{$e}, $e->[1]);

     push(@{$e}, $e->[2]);

     my $addr = $e->[0];

     my $sym = $symbols->{$addr};

     if (defined($sym)) {

       if ($#{$sym} >= 2 && $sym->[1] =~ m/^(.*):(\d+)$/) {

         $e->[1] = $1;  # File name

         $e->[2] = $2;  # Line number

       }

     }

   }

 }

 # Print source-listing for one routine

 sub PrintSource {

   my $prog = shift;

   my $offset = shift;

   my $routine = shift;

   my $flat = shift;

   my $cumulative = shift;

   my $start_addr = shift;

   my $end_addr = shift;

   my $html = shift;

   my $output = shift;

   # Disassemble all instructions (just to get line numbers)

   my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);

   GetTopLevelLineNumbers($prog, $offset, \@instructions);

   # Hack 1: assume that the first source file encountered in the

   # disassembly contains the routine

   my $filename = undef;

   for (my $i = 0; $i <= $#instructions; $i++) {

     if ($instructions[$i]->[2] >= 0) {

       $filename = $instructions[$i]->[1];

       last;

     }

   }

   if (!defined($filename)) {

     print STDERR "no filename found in $routine\n";

     return 0;

   }

   # Hack 2: assume that the largest line number from $filename is the

   # end of the procedure.  This is typically safe since if P1 contains

   # an inlined call to P2, then P2 usually occurs earlier in the

   # source file.  If this does not work, we might have to compute a

   # density profile or just print all regions we find.

   my $lastline = 0;

   for (my $i = 0; $i <= $#instructions; $i++) {

     my $f = $instructions[$i]->[1];

     my $l = $instructions[$i]->[2];

     if (($f eq $filename) && ($l > $lastline)) {

       $lastline = $l;

     }

   }

   # Hack 3: assume the first source location from "filename" is the start of

   # the source code.

   my $firstline = 1;

   for (my $i = 0; $i <= $#instructions; $i++) {

     if ($instructions[$i]->[1] eq $filename) {

       $firstline = $instructions[$i]->[2];

       last;

     }

   }

   # Hack 4: Extend last line forward until its indentation is less than

   # the indentation we saw on $firstline

   my $oldlastline = $lastline;

   {

     if (!open(FILE, "<$filename")) {

       print STDERR "$filename: $!\n";

       return 0;

     }

     my $l = 0;

     my $first_indentation = -1;

     while (<FILE>) {

       s/\r//g;         # turn windows-looking lines into unix-looking lines

       $l++;

       my $indent = Indentation($_);

       if ($l >= $firstline) {

         if ($first_indentation < 0 && $indent >= 0) {

           $first_indentation = $indent;

           last if ($first_indentation == 0);

         }

       }

       if ($l >= $lastline && $indent >= 0) {

         if ($indent >= $first_indentation) {

           $lastline = $l+1;

         } else {

           last;

         }

       }

     }

     close(FILE);

   }

   # Assign all samples to the range $firstline,$lastline,

   # Hack 4: If an instruction does not occur in the range, its samples

   # are moved to the next instruction that occurs in the range.

   my $samples1 = {};        # Map from line number to flat count

   my $samples2 = {};        # Map from line number to cumulative count

   my $running1 = 0;         # Unassigned flat counts

   my $running2 = 0;         # Unassigned cumulative counts

   my $total1 = 0;           # Total flat counts

   my $total2 = 0;           # Total cumulative counts

   my %disasm = ();          # Map from line number to disassembly

   my $running_disasm = "";  # Unassigned disassembly

   my $skip_marker = "---\n";

   if ($html) {

     $skip_marker = "";

     for (my $l = $firstline; $l <= $lastline; $l++) {

       $disasm{$l} = "";

     }

   }

   my $last_dis_filename = '';

   my $last_dis_linenum = -1;

   my $last_touched_line = -1;  # To detect gaps in disassembly for a line

   foreach my $e (@instructions) {

     # Add up counts for all address that fall inside this instruction

     my $c1 = 0;

     my $c2 = 0;

     for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {

       $c1 += GetEntry($flat, $a);

       $c2 += GetEntry($cumulative, $a);

     }

     if ($html) {

       my $dis = sprintf("      %6s %6s \t\t%8s: %s ",

                         HtmlPrintNumber($c1),

                         HtmlPrintNumber($c2),

                         UnparseAddress($offset, $e->[0]),

                         CleanDisassembly($e->[3]));

       # Append the most specific source line associated with this instruction

       if (length($dis) < 80) { $dis .= (' ' x (80 - length($dis))) };

       $dis = HtmlEscape($dis);

       my $f = $e->[5];

       my $l = $e->[6];

       if ($f ne $last_dis_filename) {

         $dis .= sprintf("<span class=disasmloc>%s:%d</span>", 

                         HtmlEscape(CleanFileName($f)), $l);

       } elsif ($l ne $last_dis_linenum) {

         # De-emphasize the unchanged file name portion

         $dis .= sprintf("<span class=unimportant>%s</span>" .

                         "<span class=disasmloc>:%d</span>", 

                         HtmlEscape(CleanFileName($f)), $l);

       } else {

         # De-emphasize the entire location

         $dis .= sprintf("<span class=unimportant>%s:%d</span>", 

                         HtmlEscape(CleanFileName($f)), $l);

       }

       $last_dis_filename = $f;

       $last_dis_linenum = $l;

       $running_disasm .= $dis;

       $running_disasm .= "\n";

     }

     $running1 += $c1;

     $running2 += $c2;

     $total1 += $c1;

     $total2 += $c2;

     my $file = $e->[1];

     my $line = $e->[2];

     if (($file eq $filename) &&

         ($line >= $firstline) &&

         ($line <= $lastline)) {

       # Assign all accumulated samples to this line

       AddEntry($samples1, $line, $running1);

       AddEntry($samples2, $line, $running2);

       $running1 = 0;

       $running2 = 0;

       if ($html) {

         if ($line != $last_touched_line && $disasm{$line} ne '') {

           $disasm{$line} .= "\n";

         }

         $disasm{$line} .= $running_disasm;

         $running_disasm = '';

         $last_touched_line = $line;

       }

     }

   }

   # Assign any leftover samples to $lastline

   AddEntry($samples1, $lastline, $running1);

   AddEntry($samples2, $lastline, $running2);

   if ($html) {

     if ($lastline != $last_touched_line && $disasm{$lastline} ne '') {

       $disasm{$lastline} .= "\n";

     }

     $disasm{$lastline} .= $running_disasm;

   }

   if ($html) {

     printf $output (

       "<h1>%s</h1>%s\n<pre onClick=\"pprof_toggle_asm()\">\n" .

       "Total:%6s %6s (flat / cumulative %s)\n",

       HtmlEscape(ShortFunctionName($routine)),

       HtmlEscape(CleanFileName($filename)),

       Unparse($total1),

       Unparse($total2),

       Units());

   } else {

     printf $output (

       "ROUTINE ====================== %s in %s\n" .

       "%6s %6s Total %s (flat / cumulative)\n",

       ShortFunctionName($routine),

       CleanFileName($filename),

       Unparse($total1),

       Unparse($total2),

       Units());

   }

   if (!open(FILE, "<$filename")) {

     print STDERR "$filename: $!\n";

     return 0;

   }

   my $l = 0;

   while (<FILE>) {

     s/\r//g;         # turn windows-looking lines into unix-looking lines

     $l++;

     if ($l >= $firstline - 5 &&

         (($l <= $oldlastline + 5) || ($l <= $lastline))) {

       chop;

       my $text = $_;

       if ($l == $firstline) { print $output $skip_marker; }

       my $n1 = GetEntry($samples1, $l);

       my $n2 = GetEntry($samples2, $l);

       if ($html) {

         # Emit a span that has one of the following classes:

         #    livesrc -- has samples

         #    deadsrc -- has disassembly, but with no samples

         #    nop     -- has no matching disasembly

         # Also emit an optional span containing disassembly.

         my $dis = $disasm{$l};

         my $asm = "";

         if (defined($dis) && $dis ne '') {

           $asm = "<span class=\"asm\">" . $dis . "</span>";

         }

         my $source_class = (($n1 + $n2 > 0) 

                             ? "livesrc" 

                             : (($asm ne "") ? "deadsrc" : "nop"));

         printf $output (

           "<span class=\"line\">%5d</span> " .

           "<span class=\"%s\">%6s %6s %s</span>%s\n",

           $l, $source_class,

           HtmlPrintNumber($n1),

           HtmlPrintNumber($n2),

           HtmlEscape($text),

           $asm);

       } else {

         printf $output(

           "%6s %6s %4d: %s\n",

           UnparseAlt($n1),

           UnparseAlt($n2),

           $l,

           $text);

       }

       if ($l == $lastline)  { print $output $skip_marker; }

     };

   }

   close(FILE);

   if ($html) {

     print $output "</pre>\n";

   }

   return 1;

 }

 # Return the source line for the specified file/linenumber.

 # Returns undef if not found.

 sub SourceLine {

   my $file = shift;

   my $line = shift;

   # Look in cache

   if (!defined($main::source_cache{$file})) {

     if (100 < scalar keys(%main::source_cache)) {

       # Clear the cache when it gets too big

       $main::source_cache = ();

     }

     # Read all lines from the file

     if (!open(FILE, "<$file")) {

       print STDERR "$file: $!\n";

       $main::source_cache{$file} = [];  # Cache the negative result

       return undef;

     }

     my $lines = [];

     push(@{$lines}, "");        # So we can use 1-based line numbers as indices

     while (<FILE>) {

       push(@{$lines}, $_);

     }

     close(FILE);

     # Save the lines in the cache

     $main::source_cache{$file} = $lines;

   }

   my $lines = $main::source_cache{$file};

   if (($line < 0) || ($line > $#{$lines})) {

     return undef;

   } else {

     return $lines->[$line];

   }

 }

 # Print disassembly for one routine with interspersed source if available

 sub PrintDisassembledFunction {

   my $prog = shift;

   my $offset = shift;

   my $routine = shift;

   my $flat = shift;

   my $cumulative = shift;

   my $start_addr = shift;

   my $end_addr = shift;

   my $total = shift;

   # Disassemble all instructions

   my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);

   # Make array of counts per instruction

   my @flat_count = ();

   my @cum_count = ();

   my $flat_total = 0;

   my $cum_total = 0;

   foreach my $e (@instructions) {

     # Add up counts for all address that fall inside this instruction

     my $c1 = 0;

     my $c2 = 0;

     for (my $a = $e->[0]; $a lt $e->[4]; $a = AddressInc($a)) {

       $c1 += GetEntry($flat, $a);

       $c2 += GetEntry($cumulative, $a);

     }

     push(@flat_count, $c1);

     push(@cum_count, $c2);

     $flat_total += $c1;

     $cum_total += $c2;

   }

   # Print header with total counts

   printf("ROUTINE ====================== %s\n" .

          "%6s %6s %s (flat, cumulative) %.1f%% of total\n",

          ShortFunctionName($routine),

          Unparse($flat_total),

          Unparse($cum_total),

          Units(),

          ($cum_total * 100.0) / $total);

   # Process instructions in order

   my $current_file = "";

   for (my $i = 0; $i <= $#instructions; ) {

     my $e = $instructions[$i];

     # Print the new file name whenever we switch files

     if ($e->[1] ne $current_file) {

       $current_file = $e->[1];

       my $fname = $current_file;

       $fname =~ s|^\./||;   # Trim leading "./"

       # Shorten long file names

       if (length($fname) >= 58) {

         $fname = "..." . substr($fname, -55);

       }

       printf("-------------------- %s\n", $fname);

     }

     # TODO: Compute range of lines to print together to deal with

     # small reorderings.

     my $first_line = $e->[2];

     my $last_line = $first_line;

     my %flat_sum = ();

     my %cum_sum = ();

     for (my $l = $first_line; $l <= $last_line; $l++) {

       $flat_sum{$l} = 0;

       $cum_sum{$l} = 0;

     }

     # Find run of instructions for this range of source lines

     my $first_inst = $i;

     while (($i <= $#instructions) &&

            ($instructions[$i]->[2] >= $first_line) &&

            ($instructions[$i]->[2] <= $last_line)) {

       $e = $instructions[$i];

       $flat_sum{$e->[2]} += $flat_count[$i];

       $cum_sum{$e->[2]} += $cum_count[$i];

       $i++;

     }

     my $last_inst = $i - 1;

     # Print source lines

     for (my $l = $first_line; $l <= $last_line; $l++) {

       my $line = SourceLine($current_file, $l);

       if (!defined($line)) {

         $line = "?\n";

         next;

       } else {

         $line =~ s/^\s+//;

       }

       printf("%6s %6s %5d: %s",

              UnparseAlt($flat_sum{$l}),

              UnparseAlt($cum_sum{$l}),

              $l,

              $line);

     }

     # Print disassembly

     for (my $x = $first_inst; $x <= $last_inst; $x++) {

       my $e = $instructions[$x];

       printf("%6s %6s    %8s: %6s\n",

              UnparseAlt($flat_count[$x]),

              UnparseAlt($cum_count[$x]),

              UnparseAddress($offset, $e->[0]),

              CleanDisassembly($e->[3]));

     }

   }

 }

 # Print DOT graph

 sub PrintDot {

   my $prog = shift;

   my $symbols = shift;

   my $raw = shift;

   my $flat = shift;

   my $cumulative = shift;

   my $overall_total = shift;

   # Get total

   my $local_total = TotalProfile($flat);

   my $nodelimit = int($main::opt_nodefraction * $local_total);

   my $edgelimit = int($main::opt_edgefraction * $local_total);

   my $nodecount = $main::opt_nodecount;

   # Find nodes to include

   my @list = (sort { abs(GetEntry($cumulative, $b)) <=>

                      abs(GetEntry($cumulative, $a))

                      || $a cmp $b }

               keys(%{$cumulative}));

   my $last = $nodecount - 1;

   if ($last > $#list) {

     $last = $#list;

   }

   while (($last >= 0) &&

          (abs(GetEntry($cumulative, $list[$last])) <= $nodelimit)) {

     $last--;

   }

   if ($last < 0) {

     print STDERR "No nodes to print\n";

     return 0;

   }

   if ($nodelimit > 0 || $edgelimit > 0) {

     printf STDERR ("Dropping nodes with <= %s %s; edges with <= %s abs(%s)\n",

                    Unparse($nodelimit), Units(),

                    Unparse($edgelimit), Units());

   }

   # Open DOT output file

   my $output;

   my $escaped_dot = ShellEscape(@DOT);

   my $escaped_ps2pdf = ShellEscape(@PS2PDF);

   if ($main::opt_gv) {

     my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "ps"));

     $output = "| $escaped_dot -Tps2 >$escaped_outfile";

   } elsif ($main::opt_evince) {

     my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "pdf"));

     $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - $escaped_outfile";

   } elsif ($main::opt_ps) {

     $output = "| $escaped_dot -Tps2";

   } elsif ($main::opt_pdf) {

     $output = "| $escaped_dot -Tps2 | $escaped_ps2pdf - -";

   } elsif ($main::opt_web || $main::opt_svg) {

     # We need to post-process the SVG, so write to a temporary file always.

     my $escaped_outfile = ShellEscape(TempName($main::next_tmpfile, "svg"));

     $output = "| $escaped_dot -Tsvg >$escaped_outfile";

   } elsif ($main::opt_gif) {

     $output = "| $escaped_dot -Tgif";

   } else {

     $output = ">&STDOUT";

   }

   open(DOT, $output) || error("$output: $!\n");

   # Title

   printf DOT ("digraph \"%s; %s %s\" {\n",

               $prog,

               Unparse($overall_total),

               Units());

   if ($main::opt_pdf) {

     # The output is more printable if we set the page size for dot.

     printf DOT ("size=\"8,11\"\n");

   }

   printf DOT ("node [width=0.375,height=0.25];\n");

   # Print legend

   printf DOT ("Legend [shape=box,fontsize=24,shape=plaintext," .

               "label=\"%s\\l%s\\l%s\\l%s\\l%s\\l\"];\n",

               $prog,

               sprintf("Total %s: %s", Units(), Unparse($overall_total)),

               sprintf("Focusing on: %s", Unparse($local_total)),

               sprintf("Dropped nodes with <= %s abs(%s)",

                       Unparse($nodelimit), Units()),

               sprintf("Dropped edges with <= %s %s",

                       Unparse($edgelimit), Units())

               );

   # Print nodes

   my %node = ();

   my $nextnode = 1;

   foreach my $a (@list[0..$last]) {

     # Pick font size

     my $f = GetEntry($flat, $a);

     my $c = GetEntry($cumulative, $a);

     my $fs = 8;

     if ($local_total > 0) {

       $fs = 8 + (50.0 * sqrt(abs($f * 1.0 / $local_total)));

     }

     $node{$a} = $nextnode++;

     my $sym = $a;

     $sym =~ s/\s+/\\n/g;

     $sym =~ s/::/\\n/g;

     # Extra cumulative info to print for non-leaves

     my $extra = "";

     if ($f != $c) {

       $extra = sprintf("\\rof %s (%s)",

                        Unparse($c),

                        Percent($c, $local_total));

     }

     my $style = "";

     if ($main::opt_heapcheck) {

       if ($f > 0) {

         # make leak-causing nodes more visible (add a background)

         $style = ",style=filled,fillcolor=gray"

       } elsif ($f < 0) {

         # make anti-leak-causing nodes (which almost never occur)

         # stand out as well (triple border)

         $style = ",peripheries=3"

       }

     }

     printf DOT ("N%d [label=\"%s\\n%s (%s)%s\\r" .

                 "\",shape=box,fontsize=%.1f%s];\n",

                 $node{$a},

                 $sym,

                 Unparse($f),

                 Percent($f, $local_total),

                 $extra,

                 $fs,

                 $style,

                );

   }

   # Get edges and counts per edge

   my %edge = ();

   my $n;

   my $fullname_to_shortname_map = {};

   FillFullnameToShortnameMap($symbols, $fullname_to_shortname_map);

   foreach my $k (keys(%{$raw})) {

     # TODO: omit low %age edges

     $n = $raw->{$k};

     my @translated = TranslateStack($symbols, $fullname_to_shortname_map, $k);

     for (my $i = 1; $i <= $#translated; $i++) {

       my $src = $translated[$i];

       my $dst = $translated[$i-1];

       #next if ($src eq $dst);  # Avoid self-edges?

       if (exists($node{$src}) && exists($node{$dst})) {

         my $edge_label = "$src\001$dst";

         if (!exists($edge{$edge_label})) {

           $edge{$edge_label} = 0;

         }

         $edge{$edge_label} += $n;

       }

     }

   }

   # Print edges (process in order of decreasing counts)

   my %indegree = ();   # Number of incoming edges added per node so far

   my %outdegree = ();  # Number of outgoing edges added per node so far

   foreach my $e (sort { $edge{$b} <=> $edge{$a} } keys(%edge)) {

     my @x = split(/\001/, $e);

     $n = $edge{$e};

     # Initialize degree of kept incoming and outgoing edges if necessary

     my $src = $x[0];

     my $dst = $x[1];

     if (!exists($outdegree{$src})) { $outdegree{$src} = 0; }

     if (!exists($indegree{$dst})) { $indegree{$dst} = 0; }

     my $keep;

     if ($indegree{$dst} == 0) {

       # Keep edge if needed for reachability

       $keep = 1;

     } elsif (abs($n) <= $edgelimit) {

       # Drop if we are below --edgefraction

       $keep = 0;

     } elsif ($outdegree{$src} >= $main::opt_maxdegree ||

              $indegree{$dst} >= $main::opt_maxdegree) {

       # Keep limited number of in/out edges per node

       $keep = 0;

     } else {

       $keep = 1;

     }

     if ($keep) {

       $outdegree{$src}++;

       $indegree{$dst}++;

       # Compute line width based on edge count

       my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0);

       if ($fraction > 1) { $fraction = 1; }

       my $w = $fraction * 2;

       if ($w < 1 && ($main::opt_web || $main::opt_svg)) {

         # SVG output treats line widths < 1 poorly.

         $w = 1;

       }

       # Dot sometimes segfaults if given edge weights that are too large, so

       # we cap the weights at a large value

       my $edgeweight = abs($n) ** 0.7;

       if ($edgeweight > 100000) { $edgeweight = 100000; }

       $edgeweight = int($edgeweight);

       my $style = sprintf("setlinewidth(%f)", $w);

       if ($x[1] =~ m/\(inline\)/) {

         $style .= ",dashed";

       }

       # Use a slightly squashed function of the edge count as the weight

       printf DOT ("N%s -> N%s [label=%s, weight=%d, style=\"%s\"];\n",

                   $node{$x[0]},

                   $node{$x[1]},

                   Unparse($n),

                   $edgeweight,

                   $style);

     }

   }

   print DOT ("}\n");

   close(DOT);

   if ($main::opt_web || $main::opt_svg) {

     # Rewrite SVG to be more usable inside web browser.

     RewriteSvg(TempName($main::next_tmpfile, "svg"));

   }

   return 1;

 }

 sub RewriteSvg {

   my $svgfile = shift;

   open(SVG, $svgfile) || die "open temp svg: $!";

   my @svg = <SVG>;

   close(SVG);

   unlink $svgfile;

   my $svg = join('', @svg);

   # Dot's SVG output is

   #

   #    <svg width="___" height="___"

   #     viewBox="___" xmlns=...>

   #    <g id="graph0" transform="...">

   #    ...

   #    </g>

   #    </svg>

   #

   # Change it to

   #

   #    <svg width="100%" height="100%"

   #     xmlns=...>

   #    $svg_javascript

   #    <g id="viewport" transform="translate(0,0)">

   #    <g id="graph0" transform="...">

   #    ...

   #    </g>

   #    </g>

   #    </svg>

   # Fix width, height; drop viewBox.

   $svg =~ s/(?s)<svg width="[^"]+" height="[^"]+"(.*?)viewBox="[^"]+"/<svg width="100%" height="100%"$1/;

   # Insert script, viewport <g> above first <g>

   my $svg_javascript = SvgJavascript();

   my $viewport = "<g id=\"viewport\" transform=\"translate(0,0)\">\n";

   $svg =~ s/<g id="graph\d"/$svg_javascript$viewport$&/;

   # Insert final </g> above </svg>.

   $svg =~ s/(.*)(<\/svg>)/$1<\/g>$2/;

   $svg =~ s/<g id="graph\d"(.*?)/<g id="viewport"$1/;

   if ($main::opt_svg) {

     # --svg: write to standard output.

     print $svg;

   } else {

     # Write back to temporary file.

     open(SVG, ">$svgfile") || die "open $svgfile: $!";

     print SVG $svg;

     close(SVG);

   }

 }

 sub SvgJavascript {

   return <<'EOF';

 <script type="text/ecmascript"><![CDATA[

 // SVGPan

 // http://www.cyberz.org/blog/2009/12/08/svgpan-a-javascript-svg-panzoomdrag-library/

 // Local modification: if(true || ...) below to force panning, never moving.

 /**

  *  SVGPan library 1.2

  * ====================

  *

  * Given an unique existing element with id "viewport", including the

  * the library into any SVG adds the following capabilities:

  *

  *  - Mouse panning

  *  - Mouse zooming (using the wheel)

  *  - Object dargging

  *

  * Known issues:

  *

  *  - Zooming (while panning) on Safari has still some issues

  *

  * Releases:

  *

  * 1.2, Sat Mar 20 08:42:50 GMT 2010, Zeng Xiaohui

  *	Fixed a bug with browser mouse handler interaction

  *

  * 1.1, Wed Feb  3 17:39:33 GMT 2010, Zeng Xiaohui

  *	Updated the zoom code to support the mouse wheel on Safari/Chrome

  *

  * 1.0, Andrea Leofreddi

  *	First release

  *

  * This code is licensed under the following BSD license:

  *

  * Copyright 2009-2010 Andrea Leofreddi <a.leofreddi@itcharm.com>. All rights reserved.

  *

  * Redistribution and use in source and binary forms, with or without modification, are

  * permitted provided that the following conditions are met:

  *

  *    1. Redistributions of source code must retain the above copyright notice, this list of

  *       conditions and the following disclaimer.

  *

  *    2. Redistributions in binary form must reproduce the above copyright notice, this list

  *       of conditions and the following disclaimer in the documentation and/or other materials

  *       provided with the distribution.

  *

  * THIS SOFTWARE IS PROVIDED BY Andrea Leofreddi ``AS IS'' AND ANY EXPRESS OR IMPLIED

  * WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND

  * FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL Andrea Leofreddi OR

  * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR

  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR

  * SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON

  * ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING

  * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF

  * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

  *

  * The views and conclusions contained in the software and documentation are those of the

  * authors and should not be interpreted as representing official policies, either expressed

  * or implied, of Andrea Leofreddi.

  */

 var root = document.documentElement;

 var state = 'none', stateTarget, stateOrigin, stateTf;

 setupHandlers(root);

 /**

  * Register handlers

  */

 function setupHandlers(root){

 	setAttributes(root, {

 		"onmouseup" : "add(evt)",

 		"onmousedown" : "handleMouseDown(evt)",

 		"onmousemove" : "handleMouseMove(evt)",

 		"onmouseup" : "handleMouseUp(evt)",

 		//"onmouseout" : "handleMouseUp(evt)", // Decomment this to stop the pan functionality when dragging out of the SVG element

 	});

 	if(navigator.userAgent.toLowerCase().indexOf('webkit') >= 0)

 		window.addEventListener('mousewheel', handleMouseWheel, false); // Chrome/Safari

 	else

 		window.addEventListener('DOMMouseScroll', handleMouseWheel, false); // Others

 	var g = svgDoc.getElementById("svg");

 	g.width = "100%";

 	g.height = "100%";

 }

 /**

  * Instance an SVGPoint object with given event coordinates.

  */

 function getEventPoint(evt) {

 	var p = root.createSVGPoint();

 	p.x = evt.clientX;

 	p.y = evt.clientY;

 	return p;

 }

 /**

  * Sets the current transform matrix of an element.

  */

 function setCTM(element, matrix) {

 	var s = "matrix(" + matrix.a + "," + matrix.b + "," + matrix.c + "," + matrix.d + "," + matrix.e + "," + matrix.f + ")";

 	element.setAttribute("transform", s);

 }

 /**

  * Dumps a matrix to a string (useful for debug).

  */

 function dumpMatrix(matrix) {

 	var s = "[ " + matrix.a + ", " + matrix.c + ", " + matrix.e + "\n  " + matrix.b + ", " + matrix.d + ", " + matrix.f + "\n  0, 0, 1 ]";

 	return s;

 }

 /**

  * Sets attributes of an element.

  */

 function setAttributes(element, attributes){

 	for (i in attributes)

 		element.setAttributeNS(null, i, attributes[i]);

 }

 /**

  * Handle mouse move event.

  */

 function handleMouseWheel(evt) {

 	if(evt.preventDefault)

 		evt.preventDefault();

 	evt.returnValue = false;

 	var svgDoc = evt.target.ownerDocument;

 	var delta;

 	if(evt.wheelDelta)

 		delta = evt.wheelDelta / 3600; // Chrome/Safari

 	else

 		delta = evt.detail / -90; // Mozilla

 	var z = 1 + delta; // Zoom factor: 0.9/1.1

 	var g = svgDoc.getElementById("viewport");

 	var p = getEventPoint(evt);

 	p = p.matrixTransform(g.getCTM().inverse());

 	// Compute new scale matrix in current mouse position

 	var k = root.createSVGMatrix().translate(p.x, p.y).scale(z).translate(-p.x, -p.y);

         setCTM(g, g.getCTM().multiply(k));

 	stateTf = stateTf.multiply(k.inverse());

 }

 /**

  * Handle mouse move event.

  */

 function handleMouseMove(evt) {

 	if(evt.preventDefault)

 		evt.preventDefault();

 	evt.returnValue = false;

 	var svgDoc = evt.target.ownerDocument;

 	var g = svgDoc.getElementById("viewport");

 	if(state == 'pan') {

 		// Pan mode

 		var p = getEventPoint(evt).matrixTransform(stateTf);

 		setCTM(g, stateTf.inverse().translate(p.x - stateOrigin.x, p.y - stateOrigin.y));

 	} else if(state == 'move') {

 		// Move mode

 		var p = getEventPoint(evt).matrixTransform(g.getCTM().inverse());

 		setCTM(stateTarget, root.createSVGMatrix().translate(p.x - stateOrigin.x, p.y - stateOrigin.y).multiply(g.getCTM().inverse()).multiply(stateTarget.getCTM()));

 		stateOrigin = p;

 	}

 }

 /**

  * Handle click event.

  */

 function handleMouseDown(evt) {

 	if(evt.preventDefault)

 		evt.preventDefault();

 	evt.returnValue = false;

 	var svgDoc = evt.target.ownerDocument;

 	var g = svgDoc.getElementById("viewport");

 	if(true || evt.target.tagName == "svg") {

 		// Pan mode

 		state = 'pan';

 		stateTf = g.getCTM().inverse();

 		stateOrigin = getEventPoint(evt).matrixTransform(stateTf);

 	} else {

 		// Move mode

 		state = 'move';

 		stateTarget = evt.target;

 		stateTf = g.getCTM().inverse();

 		stateOrigin = getEventPoint(evt).matrixTransform(stateTf);

 	}

 }

 /**

  * Handle mouse button release event.

  */

 function handleMouseUp(evt) {

 	if(evt.preventDefault)

 		evt.preventDefault();

 	evt.returnValue = false;

 	var svgDoc = evt.target.ownerDocument;

 	if(state == 'pan' || state == 'move') {

 		// Quit pan mode

 		state = '';

 	}

 }

 ]]></script>

 EOF

 }

 # Provides a map from fullname to shortname for cases where the

 # shortname is ambiguous.  The symlist has both the fullname and

 # shortname for all symbols, which is usually fine, but sometimes --

 # such as overloaded functions -- two different fullnames can map to

 # the same shortname.  In that case, we use the address of the

 # function to disambiguate the two.  This function fills in a map that

 # maps fullnames to modified shortnames in such cases.  If a fullname

 # is not present in the map, the 'normal' shortname provided by the

 # symlist is the appropriate one to use.

 sub FillFullnameToShortnameMap {

   my $symbols = shift;

   my $fullname_to_shortname_map = shift;

   my $shortnames_seen_once = {};

   my $shortnames_seen_more_than_once = {};

   foreach my $symlist (values(%{$symbols})) {

     # TODO(csilvers): deal with inlined symbols too.

     my $shortname = $symlist->[0];

     my $fullname = $symlist->[2];

     if ($fullname !~ /<[0-9a-fA-F]+>$/) {  # fullname doesn't end in an address

       next;       # the only collisions we care about are when addresses differ

     }

     if (defined($shortnames_seen_once->{$shortname}) &&

         $shortnames_seen_once->{$shortname} ne $fullname) {

       $shortnames_seen_more_than_once->{$shortname} = 1;

     } else {

       $shortnames_seen_once->{$shortname} = $fullname;

     }

   }

   foreach my $symlist (values(%{$symbols})) {

     my $shortname = $symlist->[0];

     my $fullname = $symlist->[2];

     # TODO(csilvers): take in a list of addresses we care about, and only

     # store in the map if $symlist->[1] is in that list.  Saves space.

     next if defined($fullname_to_shortname_map->{$fullname});

     if (defined($shortnames_seen_more_than_once->{$shortname})) {

       if ($fullname =~ /<0*([^>]*)>$/) {   # fullname has address at end of it

         $fullname_to_shortname_map->{$fullname} = "$shortname\@$1";

       }

     }

   }

 }

 # Return a small number that identifies the argument.

 # Multiple calls with the same argument will return the same number.

 # Calls with different arguments will return different numbers.

 sub ShortIdFor {

   my $key = shift;

   my $id = $main::uniqueid{$key};

   if (!defined($id)) {

     $id = keys(%main::uniqueid) + 1;

     $main::uniqueid{$key} = $id;

   }

   return $id;

 }

 # Translate a stack of addresses into a stack of symbols

 sub TranslateStack {

   my $symbols = shift;

   my $fullname_to_shortname_map = shift;

   my $k = shift;

   my @addrs = split(/\n/, $k);

   my @result = ();

   for (my $i = 0; $i <= $#addrs; $i++) {

     my $a = $addrs[$i];

     # Skip large addresses since they sometimes show up as fake entries on RH9

     if (length($a) > 8 && $a gt "7fffffffffffffff") {

       next;

     }

     if ($main::opt_disasm || $main::opt_list) {

       # We want just the address for the key

       push(@result, $a);

       next;

     }

     my $symlist = $symbols->{$a};

     if (!defined($symlist)) {

       $symlist = [$a, "", $a];

     }

     # We can have a sequence of symbols for a particular entry

     # (more than one symbol in the case of inlining).  Callers

     # come before callees in symlist, so walk backwards since

     # the translated stack should contain callees before callers.

     for (my $j = $#{$symlist}; $j >= 2; $j -= 3) {

       my $func = $symlist->[$j-2];

       my $fileline = $symlist->[$j-1];

       my $fullfunc = $symlist->[$j];

       if (defined($fullname_to_shortname_map->{$fullfunc})) {

         $func = $fullname_to_shortname_map->{$fullfunc};

       }

       if ($j > 2) {

         $func = "$func (inline)";

       }

       # Do not merge nodes corresponding to Callback::Run since that

       # causes confusing cycles in dot display.  Instead, we synthesize

       # a unique name for this frame per caller.

       if ($func =~ m/Callback.*::Run$/) {

         my $caller = ($i > 0) ? $addrs[$i-1] : 0;

         $func = "Run#" . ShortIdFor($caller);

       }

       if ($main::opt_addresses) {

         push(@result, "$a $func $fileline");

       } elsif ($main::opt_lines) {

         if ($func eq '??' && $fileline eq '??:0') {

           push(@result, "$a");

         } else {

           push(@result, "$func $fileline");

         }

       } elsif ($main::opt_functions) {

         if ($func eq '??') {

           push(@result, "$a");

         } else {

           push(@result, $func);

         }

       } elsif ($main::opt_files) {

         if ($fileline eq '??:0' || $fileline eq '') {

           push(@result, "$a");

         } else {

           my $f = $fileline;

           $f =~ s/:\d+$//;

           push(@result, $f);

         }

       } else {

         push(@result, $a);

         last;  # Do not print inlined info

       }

     }

   }

   # print join(",", @addrs), " => ", join(",", @result), "\n";

   return @result;

 }

 # Generate percent string for a number and a total

 sub Percent {

   my $num = shift;

   my $tot = shift;

   if ($tot != 0) {

     return sprintf("%.1f%%", $num * 100.0 / $tot);

   } else {

     return ($num == 0) ? "nan" : (($num > 0) ? "+inf" : "-inf");

   }

 }