xref: /external/jemalloc/bin/pprof

#! /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/&/&amp;/g;
  $text =~ s/</&lt;/g;
  $text =~ s/>/&gt;/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.