#! /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 = "0.93";

# These are the object tools we use, which come from various sources.
# We want to invoke them directly, rather than via users' aliases and/or
# search paths, because some people have colorizing versions of them that
# can cause trouble, or because the default versions on a system may not
# deal with 64-bit objects if 64-bit profiles are being analyzed.
# (However, we will default to the user's defaults if we can't find better.)
# See ConfigureObjTools near the bottom of this script.
my %obj_tool_map = (
  "objdump" => "objdump",
  "nm" => "nm",
  "addr2line" => "addr2line",
  "c++filt" => "c++filt",
);
my $DOT = "dot";          # leave non-absolute, since it may be in /usr/local
my $GV = "gv";
my $PS2PDF = "ps2pdf";
# These are used for dynamic profiles
my $WGET = "wget";
my $CURL = "curl";

# 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 $GROWTH_PAGE = "/pprof/growth";
my $CONTENTION_PAGE = "/pprof/contention";
my $SYMBOL_PAGE = "/pprof/symbol";     # must support symbol lookup via POST
my $PROGRAM_NAME_PAGE = "/pprof/cmdline";


# 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:
my $address_length = 8;   # Hope for 32-bit, reset if 64-bit detected.

# A list of paths to search for shared object files
my @prefix_list = ();

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

sub usage_string {
  return <<EOF;
Usage:
pprof [options] <program> <profiles>
   <profiles> is a space separated list of profile names.
pprof [options] <profile>
   <profile> is a remote form.  Symbols are obtained from host:port$SYMBOL_PAGE

   Each profile 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, $GROWTH_PAGE, or $CONTENTION_PAGE.
   For instance: "pprof http://myserver.com:80$HEAP_PAGE".
   If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling).

   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/google-perftools-$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
   --gv                Generate Postscript and display
   --list=<regexp>     Generate source listing of matching routines
   --disasm=<regexp>   Generate disassembly of matching routines
   --dot               Generate DOT file to stdout
   --ps                Generate Postcript to stdout
   --pdf               Generate PDF to stdout
   --gif               Generate GIF to stdout

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]
   --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>    Prefix for object tool pathnames
   --test              Run unit tests
   --help              This message
   --version           Version information

Examples:

pprof /bin/ls ls.prof
                       Enters "interactive" mode
pprof --text /bin/ls ls.prof
                       Outputs one line per procedure
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 --text localhost:1234
                       Outputs one line per procedure for localhost:1234
EOF
}

sub version_string {
  return <<EOF
pprof (part of google-perftools $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;


  $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_list = "";
  $main::opt_disasm = "";
  $main::opt_gv = 0;
  $main::opt_dot = 0;
  $main::opt_ps = 0;
  $main::opt_pdf = 0;
  $main::opt_gif = 0;

  $main::opt_nodecount = 80;
  $main::opt_nodefraction = 0.005;
  $main::opt_edgefraction = 0.001;
  $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;

  # Are we using $SYMBOL_PAGE?
  $main::use_symbol_page = 0;

  # 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,
             "list=s"         => \$main::opt_list,
             "disasm=s"       => \$main::opt_disasm,
             "gv!"            => \$main::opt_gv,
             "dot!"           => \$main::opt_dot,
             "ps!"            => \$main::opt_ps,
             "pdf!"           => \$main::opt_pdf,
             "gif!"           => \$main::opt_gif,
             "interactive!"   => \$main::opt_interactive,
             "nodecount=i"    => \$main::opt_nodecount,
             "nodefraction=f" => \$main::opt_nodefraction,
             "edgefraction=f" => \$main::opt_edgefraction,
             "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,
      ) || 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 mode requires address-level info
  if ($main::opt_disasm || $main::opt_list) {
    $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_list eq '' ? 0 : 1) +
      ($main::opt_disasm eq '' ? 0 : 1) +
      $main::opt_gv +
      $main::opt_dot +
      $main::opt_ps +
      $main::opt_pdf +
      $main::opt_gif +
      $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 (IsProfileURL($ARGV[0])) {
    $main::use_symbol_page = 1;
  }

  if ($main::use_symbol_page) {  # 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");
  } 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;
      for (my $i = 0; $i < $num_machines; $i++) {
        unshift(@main::pfile_args, "$i.$machine");
      }
    } 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();
  } else {
    ConfigureObjTools($main::prog)
  }

  # Break the opt_list_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();

  # Fetch all profile data
  FetchDynamicProfiles();

  # 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

  # 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});
    }
  }

  # Subtract base from profile, if specified
  if ($main::opt_base ne '') {
    my $base = ReadProfile($main::prog, $main::opt_base)->{profile};
    $profile = SubtractProfile($profile, $base);
  }

  # Get total data in profile
  my $total = TotalProfile($profile);

  # Collect symbols
  my $symbols = undef;
  if ($main::use_symbol_page) {
    $symbols = FetchSymbols($pcs);
  } else {
    $symbols = ExtractSymbols($libs, $profile, $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);
  }

  # 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($libs, $flat, $cumulative, $main::opt_list);
    } elsif ($main::opt_text) {
      PrintText($symbols, $flat, $cumulative, $total, -1);
    } else {
      if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
        if ($main::opt_gv) {
	  RunGV(PsTempName($main::next_tmpfile), "");
        }
      } else {
        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("$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("$GV --scale=$main::opt_scale --noantialias " . $fname . $bg);
  } else {
    # Old gv version - only supports options that use single dash.
    print STDERR "$GV -scale $main::opt_scale\n";
    system("$GV -scale $main::opt_scale " . $fname . $bg);
  }
}


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

sub InteractiveMode {
  $| = 1;  # Make output unbuffered for interactive mode
  my ($orig_profile, $symbols, $libs, $total) = @_;

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

  # Use ReadLine if it's installed.
  if ( !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 "(pprof) ";
      $_ = <STDIN>;

      # 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 "\n";
    return 0;
  }
  if (m/^ *quit/) {
    return 0;
  }
  if (m/^ *help/) {
    InteractiveHelpMessage();
    return 1;
  }
  # Clear all the mode options -- mode is controlled by "$command"
  $main::opt_text = 0;
  $main::opt_disasm = 0;
  $main::opt_list = 0;
  $main::opt_gv = 0;
  $main::opt_cum = 0;

  if (m/^ *(text|top)(\d*) *(.*)/) {
    $main::opt_text = 1;

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

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

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

    # Get derived profiles
    my $flat = FlatProfile($reduced);
    my $cumulative = CumulativeProfile($reduced);

    PrintText($symbols, $flat, $cumulative, $total, $line_limit);
    return 1;
  }
  if (m/^ *list *(.+)/) {
    $main::opt_list = 1;

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

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

    # Get derived profiles
    my $flat = FlatProfile($reduced);
    my $cumulative = CumulativeProfile($reduced);

    PrintListing($libs, $flat, $cumulative, $routine);
    return 1;
  }
  if (m/^ *disasm *(.+)/) {
    $main::opt_disasm = 1;

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

    # Process current profile to account for various settings
    my $profile = ProcessProfile($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/^ *gv *(.*)/) {
    $main::opt_gv = 1;

    my $focus;
    my $ignore;
    ($focus, $ignore) = ParseInteractiveArgs($1);

    # Process current profile to account for various settings
    my $profile = ProcessProfile($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)) {
      RunGV(PsTempName($main::next_tmpfile), " &");
      $main::next_tmpfile++;
    }
    return 1;
  }
  return 1;
}


sub ProcessProfile {
  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;
  my $total_count = TotalProfile($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 <<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.

  list [routine_regexp] [-ignore1] [-ignore2]
      Show source listing of routines whose names match "routine_regexp"

  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.

  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/google-perftools-$PPROF_VERSION/cpu_profiler.html
 /usr/doc/google-perftools-$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 "Ignoring samples in call stacks that match '$ignore'\n";
  }
  return ($focus, $ignore);
}

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

sub PsTempName {
  my $fnum = shift;
  return "$main::tmpfile_ps" . "." . "$fnum" . ".ps";
}

# Print text output
sub PrintText {
  my $symbols = shift;
  my $flat = shift;
  my $cumulative = shift;
  my $total = shift;
  my $line_limit = shift;

  # 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) }
                 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);
  }
}

# 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;

  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 $total_flat = 0;
      my $total_cum = 0;
      my $length = hex(AddressSub($end_addr, $start_addr));
      my $addr = AddressAdd($start_addr, $offset);
      for (my $i = 0; $i < $length; $i++) {
        $total_cum += GetEntry($cumulative, $addr);
        $total_flat += GetEntry($flat, $addr);
        $addr = AddressInc($addr);
      }

      # Skip disassembly if there are no samples in routine
      next if ($total_cum == 0);

      print "ROUTINE ====================== $routine\n";
      printf "%6s %6s Total %s (flat / cumulative)\n",
        Unparse($total_flat), Unparse($total_cum), Units();

      my @instructions = Disassemble($lib->[0], $offset,
                                     $start_addr, $end_addr);
      foreach my $e (@instructions) {
        my $location = ($e->[2] >= 0) ? "$e->[1]:$e->[2]" : "";
        $location =~ s|.*/||;   # Remove directory portion, if any
        if (length($location) >= 20) {
          # For long locations, just show the last 20 characters
          $location = substr($location, -20);
        }
        my $f = GetEntry($flat, $e->[0]);
        my $c = GetEntry($cumulative, $e->[0]);
        my $address = $e->[0];
        $address =~ s/^0x//;
        printf("%6s %6s %-20s %8s: %6s\n",
               UnparseAlt($f),
               UnparseAlt($c),
               $location,
               $address,
               $e->[3]);
      }
    }
  }
}

# Return reference to array of tuples of the form:
#       [address, filename, linenumber, instruction]
# E.g.,
#       ["0x806c43d", "/foo/bar.cc", 131, "ret"]
sub Disassemble {
  my $prog = shift;
  my $offset = shift;
  my $start_addr = shift;
  my $end_addr = shift;

  my $objdump = $obj_tool_map{"objdump"};
  my $cmd = sprintf("$objdump -d -l --no-show-raw-insn " .
                    "--start-address=0x$start_addr " .
                    "--stop-address=0x$end_addr $prog");
  open(OBJDUMP, "$cmd |") || error("$objdump: $!\n");
  my @result = ();
  my $filename = "";
  my $linenumber = -1;
  while (<OBJDUMP>) {
    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);
      push(@result, [$k, $filename, $linenumber, $2]);
    }
  }
  close(OBJDUMP);
  return @result;
}

# For sorting functions by name
sub ByName {
  return ShortFunctionName($a) cmp ShortFunctionName($b);
}

# Print source-listing for all all routines that match $main::opt_list
sub PrintListing {
  my $libs = shift;
  my $flat = shift;
  my $cumulative = shift;
  my $list_opts = shift;

  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})) {
          PrintSource($lib->[0], $offset,
                      $routine, $flat, $cumulative,
                      $start_addr, $end_addr);
          last;
        }
        $addr = AddressInc($addr);
      }
    }
  }
}

# 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;
  }
}

# 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;

  # Disassemble all instructions (just to get line numbers)
  my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);

  # 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;
  }

  # 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;
    }
    my $l = 0;
    my $first_indentation = -1;
    while (<FILE>) {
      $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 = {};
  my $samples2 = {};
  my $running1 = 0;     # Unassigned flat counts
  my $running2 = 0;     # Unassigned cumulative counts
  my $total1 = 0;       # Total flat counts
  my $total2 = 0;       # Total cumulative counts
  foreach my $e (@instructions) {
    my $c1 = GetEntry($flat, $e->[0]);
    my $c2 = GetEntry($cumulative, $e->[0]);
    $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;
    }
  }

  # Assign any leftover samples to $lastline
  AddEntry($samples1, $lastline, $running1);
  AddEntry($samples2, $lastline, $running2);

  printf("ROUTINE ====================== %s in %s\n" .
         "%6s %6s Total %s (flat / cumulative)\n",
         ShortFunctionName($routine),
         $filename,
         Units(),
         Unparse($total1),
         Unparse($total2));
  if (!open(FILE, "<$filename")) {
    print STDERR "$filename: $!\n";
    return;
  }
  my $l = 0;
  while (<FILE>) {
    $l++;
    if ($l >= $firstline - 5 &&
        (($l <= $oldlastline + 5) || ($l <= $lastline))) {
      chop;
      my $text = $_;
      if ($l == $firstline) { printf("---\n"); }
      printf("%6s %6s %4d: %s\n",
             UnparseAlt(GetEntry($samples1, $l)),
             UnparseAlt(GetEntry($samples2, $l)),
             $l,
             $text);
      if ($l == $lastline)  { printf("---\n"); }
    };
  }
  close(FILE);
}

# 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)) }
              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";
    cleanup();
    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;
  if ($main::opt_gv) {
    $output = "| $DOT -Tps >" . PsTempName($main::next_tmpfile);
  } elsif ($main::opt_ps) {
    $output = "| $DOT -Tps";
  } elsif ($main::opt_pdf) {
    $output = "| $DOT -Tps | $PS2PDF - -";
  } elsif ($main::opt_gif) {
    $output = "| $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, $overall_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, $overall_total),
                $extra,
                $fs,
                $style,
               );
  }

  # Get edges and counts per edge
  my %edge = ();
  my $n;
  foreach my $k (keys(%{$raw})) {
    # TODO: omit low %age edges
    $n = $raw->{$k};
    my @addrs = split(/\n/, $k);
    for (my $i = 1; $i <= $#addrs; $i++) {
      my $src = OutputKey($symbols, $addrs[$i]);
      my $dst = OutputKey($symbols, $addrs[$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
  foreach my $e (keys(%edge)) {
    my @x = split(/\001/, $e);
    $n = $edge{$e};

    if (abs($n) > $edgelimit) {
      # 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) { $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);

      # Use a slightly squashed function of the edge count as the weight
      printf DOT ("N%s -> N%s [label=%s, weight=%d, " .
                  "style=\"setlinewidth(%f)\"];\n",
                  $node{$x[0]},
                  $node{$x[1]},
                  Unparse($n),
                  $edgeweight,
                  $w);
    }
  }

  print DOT ("}\n");

  close(DOT);
  return 1;
}

# Generate the key under which a given address should be counted
# based on the user-specified output granularity.
sub OutputKey {
  my $symbols = shift;
  my $a = shift;

  # Skip large addresses since they sometimes show up as fake entries on RH9
  if (length($a) > 8) {
    if ($a gt "7fffffffffffffff") { return ''; }
  }

  # Extract symbolic info for address
  my $func = $a;
  my $fullfunc = $a;
  my $fileline = "";
  if (exists($symbols->{$a})) {
    $func = $symbols->{$a}->[0];
    $fullfunc = $symbols->{$a}->[2];
    $fileline = $symbols->{$a}->[1];
  }

  if ($main::opt_disasm || $main::opt_list) {
    return $a;   # We want just the address for the key
  } elsif ($main::opt_addresses) {
    return "$a $func $fileline";
  } elsif ($main::opt_lines) {
    return "$func $fileline";
  } elsif ($main::opt_functions) {
    return $func;
  } elsif ($main::opt_files) {
    my $f = ($fileline eq '') ? $a : $fileline;
    $f =~ s/:\d+$//;
    return $f;
  } else {
    return $a;
  }
}

# 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");
  }
}

# Generate pretty-printed form of number
sub Unparse {
  my $num = shift;
  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
    if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
      return sprintf("%d", $num);
    } else {
      if ($main::opt_show_bytes) {
        return sprintf("%d", $num);
      } else {
        return sprintf("%.1f", $num / 1048576.0);
      }
    }
  } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
    return sprintf("%.3f", $num / 1e9);	# Convert nanoseconds to seconds
  } else {
    return sprintf("%d", $num);
  }
}

# Alternate pretty-printed form: 0 maps to "."
sub UnparseAlt {
  my $num = shift;
  if ($num == 0) {
    return ".";
  } else {
    return Unparse($num);
  }
}

# Return output units
sub Units {
  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
    if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
      return "objects";
    } else {
      if ($main::opt_show_bytes) {
        return "B";
      } else {
        return "MB";
      }
    }
  } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
    return "seconds";
  } else {
    return "samples";
  }
}

##### Profile manipulation code #####

# Generate flattened profile:
# If count is charged to stack [a,b,c,d], in generated profile,
# it will be charged to [a]
sub FlatProfile {
  my $profile = shift;
  my $result = {};
  foreach my $k (keys(%{$profile})) {
    my $count = $profile->{$k};
    my @addrs = split(/\n/, $k);
    if ($#addrs >= 0) {
      AddEntry($result, $addrs[0], $count);
    }
  }
  return $result;
}

# Generate cumulative profile:
# If count is charged to stack [a,b,c,d], in generated profile,
# it will be charged to [a], [b], [c], [d]
sub CumulativeProfile {
  my $profile = shift;
  my $result = {};
  foreach my $k (keys(%{$profile})) {
    my $count = $profile->{$k};
    my @addrs = split(/\n/, $k);
    foreach my $a (@addrs) {
      AddEntry($result, $a, $count);
    }
  }
  return $result;
}

# If the second-youngest PC on the stack is always the same, returns
# that pc.  Otherwise, returns undef.
sub IsSecondPcAlwaysTheSame {
  my $profile = shift;

  my $second_pc = undef;
  foreach my $k (keys(%{$profile})) {
    my @addrs = split(/\n/, $k);
    if ($#addrs < 1) {
      return undef;
    }
    if (not defined $second_pc) {
      $second_pc = $addrs[1];
    } else {
      if ($second_pc ne $addrs[1]) {
        return undef;
      }
    }
  }
  return $second_pc;
}

sub RemoveUninterestingFrames {
  my $symbols = shift;
  my $profile = shift;

  # List of function names to skip
  my %skip = ();
  my $skip_regexp = 'NOMATCH';
  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
    foreach my $name ('calloc',
                      'cfree',
                      'malloc',
                      'free',
                      'memalign',
                      'pvalloc',
                      'valloc',
                      'realloc',
                      'do_malloc',
                      'DoSampledAllocation',
		      'simple_alloc::allocate',
		      '__malloc_alloc_template::allocate',
                      '__builtin_delete',
                      '__builtin_new',
                      '__builtin_vec_delete',
                      '__builtin_vec_new',
                      'operator new',
                      'operator new[]') {
      $skip{$name} = 1;
    }
    $skip_regexp = "TCMalloc";
  } elsif ($main::profile_type eq 'contention') {
    foreach my $vname ('Mutex::Unlock', 'Mutex::UnlockSlow') {
      $skip{$vname} = 1;
    }
  } elsif ($main::profile_type eq 'cpu') {
    # Drop signal handlers used for CPU profile collection
    # TODO(dpeng): this should not be necessary; it's taken
    # care of by the general 2nd-pc mechanism below.
    foreach my $name ('ProfileData::Add',           # historical
		      'ProfileData::prof_handler',  # historical
		      'CpuProfiler::prof_handler',
		      '__pthread_sighandler',
		      '__restore') {
      $skip{$name} = 1;
    }
  } else {
    # Nothing skipped for unknown types
  }

  if ($main::profile_type eq 'cpu') {
    # If all the second-youngest program counters are the same,
    # this STRONGLY suggests that it is an artifact of measurement,
    # i.e., stack frames pushed by the CPU profiler signal handler.
    # Hence, we delete them.
    # (The topmost PC is read from the signal structure, not from
    # the stack, so it does not get involved.)
    while (my $second_pc = IsSecondPcAlwaysTheSame($profile)) {
      my $result = {};
      my $func = '';
      if (exists($symbols->{$second_pc})) {
        $second_pc = $symbols->{$second_pc}->[0];
      }
      print STDERR "Removing $second_pc from all stack traces.\n";
      foreach my $k (keys(%{$profile})) {
        my $count = $profile->{$k};
        my @addrs = split(/\n/, $k);
        splice @addrs, 1, 1;
        my $reduced_path = join("\n", @addrs);
        AddEntry($result, $reduced_path, $count);
      }
      $profile = $result;
    }
  }

  my $result = {};
  foreach my $k (keys(%{$profile})) {
    my $count = $profile->{$k};
    my @addrs = split(/\n/, $k);
    my @path = ();
    foreach my $a (@addrs) {
      if (exists($symbols->{$a})) {
	my $func = $symbols->{$a}->[0];
	if ($skip{$func} || ($func =~ m/$skip_regexp/)) {
	  next;
	}
      }
      push(@path, $a);
    }
    my $reduced_path = join("\n", @path);
    AddEntry($result, $reduced_path, $count);
  }
  return $result;
}

# Reduce profile to granularity given by user
sub ReduceProfile {
  my $symbols = shift;
  my $profile = shift;
  my $result = {};
  foreach my $k (keys(%{$profile})) {
    my $count = $profile->{$k};
    my @addrs = split(/\n/, $k);
    my @path = ();
    my %seen = ();
    $seen{''} = 1;      # So that empty keys are skipped
    foreach my $a (@addrs) {
      # To avoid double-counting due to recursion, skip a stack-trace
      # entry if it has already been seen
      my $key = OutputKey($symbols, $a);
      if (!$seen{$key}) {
	$seen{$key} = 1;
	push(@path, $key);
      }
    }
    my $reduced_path = join("\n", @path);
    AddEntry($result, $reduced_path, $count);
  }
  return $result;
}

# Focus only on paths involving specified regexps
sub FocusProfile {
  my $symbols = shift;
  my $profile = shift;
  my $focus = shift;
  my $result = {};
  foreach my $k (keys(%{$profile})) {
    my $count = $profile->{$k};
    my @addrs = split(/\n/, $k);
    foreach my $a (@addrs) {
      # Reply if it matches either the address/shortname/fileline
      if (($a =~ m/$focus/) ||
          (exists($symbols->{$a}) &&
           (($symbols->{$a}->[0] =~ m/$focus/) ||
            ($symbols->{$a}->[1] =~ m/$focus/)))) {
        AddEntry($result, $k, $count);
        last;
      }
    }
  }
  return $result;
}

# Focus only on paths not involving specified regexps
sub IgnoreProfile {
  my $symbols = shift;
  my $profile = shift;
  my $ignore = shift;
  my $result = {};
  foreach my $k (keys(%{$profile})) {
    my $count = $profile->{$k};
    my @addrs = split(/\n/, $k);
    my $matched = 0;
    foreach my $a (@addrs) {
      # Reply if it matches either the address/shortname/fileline
      if (($a =~ m/$ignore/) ||
          (exists($symbols->{$a}) &&
           (($symbols->{$a}->[0] =~ m/$ignore/) ||
            ($symbols->{$a}->[1] =~ m/$ignore/)))) {
        $matched = 1;
        last;
      }
    }
    if (!$matched) {
      AddEntry($result, $k, $count);
    }
  }
  return $result;
}

# Get total count in profile
sub TotalProfile {
  my $profile = shift;
  my $result = 0;
  foreach my $k (keys(%{$profile})) {
    $result += $profile->{$k};
  }
  return $result;
}

# Add A to B
sub AddProfile {
  my $A = shift;
  my $B = shift;

  my $R = {};
  # add all keys in A
  foreach my $k (keys(%{$A})) {
    my $v = $A->{$k};
    AddEntry($R, $k, $v);
  }
  # add all keys in B
  foreach my $k (keys(%{$B})) {
    my $v = $B->{$k};
    AddEntry($R, $k, $v);
  }
  return $R;
}

# Add A to B
sub AddPcs {
  my $A = shift;
  my $B = shift;

  my $R = {};
  # add all keys in A
  foreach my $k (keys(%{$A})) {
    $R->{$k} = 1
  }
  # add all keys in B
  foreach my $k (keys(%{$B})) {
    $R->{$k} = 1
  }
  return $R;
}

# Subtract B from A
sub SubtractProfile {
  my $A = shift;
  my $B = shift;

  my $R = {};
  foreach my $k (keys(%{$A})) {
    my $v = $A->{$k} - GetEntry($B, $k);
    if ($v < 0 && $main::opt_drop_negative) {
      $v = 0;
    }
    AddEntry($R, $k, $v);
  }
  if (!$main::opt_drop_negative) {
    # Take care of when subtracted profile has more entries
    foreach my $k (keys(%{$B})) {
      if (!exists($A->{$k})) {
        AddEntry($R, $k, 0 - $B->{$k});
      }
    }
  }
  return $R;
}

# Get entry from profile; zero if not present
sub GetEntry {
  my $profile = shift;
  my $k = shift;
  if (exists($profile->{$k})) {
    return $profile->{$k};
  } else {
    return 0;
  }
}

# Add entry to specified profile
sub AddEntry {
  my $profile = shift;
  my $k = shift;
  my $n = shift;
  if (!exists($profile->{$k})) {
    $profile->{$k} = 0;
  }
  $profile->{$k} += $n;
}

# Add a stack of entries to specified profile, and add them to the $pcs
# list.
sub AddEntries {
  my $profile = shift;
  my $pcs = shift;
  my $stack = shift;
  my $count = shift;
  my @k = ();

  foreach my $e (split(/\s+/, $stack)) {
    my $pc = HexExtend($e);
    $pcs->{$pc} = 1;
    push @k, $pc;
  }
  AddEntry($profile, (join "\n", @k), $count);
}

##### Code to profile a server dynamically #####

sub CheckSymbolPage {
  my $url = SymbolPageURL();
  open(SYMBOL, "$WGET -qO- '$url' |");
  my $line = <SYMBOL>;
  close(SYMBOL);
  unless (defined($line)) {
    error("$url doesn't exist\n");
  }

  if ($line =~ /^num_symbols:\s+(\d+)$/) {
    if ($1 == 0) {
      error("Stripped binary. No symbols available.\n");
    }
  } else {
    error("Failed to get the number of symbols from $url\n");
  }
}

sub IsProfileURL {
  my $profile_name = shift;
  my ($host, $port, $type) = ParseProfileURL($profile_name);
  return defined($host) and defined($port) and defined($type);
}

sub ParseProfileURL {
  my $profile_name = shift;
  if (defined($profile_name) &&
      $profile_name =~ m,^(http://|)([^/:]+):(\d+)(|/|$PROFILE_PAGE|$HEAP_PAGE|$GROWTH_PAGE|$CONTENTION_PAGE)$,o) {
    return ($2, $3, $4);
  }
  return ();
}

# We fetch symbols from the first profile argument.
sub SymbolPageURL {
  my ($host, $port, $type) = ParseProfileURL($main::pfile_args[0]);
  return "http://$host:$port$SYMBOL_PAGE";
}

sub FetchProgramName() {
  my ($host, $port, $type) = ParseProfileURL($main::pfile_args[0]);
  my $url = "http://$host:$port$PROGRAM_NAME_PAGE";
  my $command_line = "$WGET -qO- '$url'";
  open(CMDLINE, "$command_line |") or error($command_line);
  my $cmdline = <CMDLINE>;
  close(CMDLINE);
  error("Failed to get program name from $url\n") unless defined($cmdline);
  $cmdline =~ s/\x00.+//;  # Remove argv[1] and latters.
  $cmdline =~ s!\n!!g;  # Remove LFs.
  return $cmdline;
}

# Gee, curl's -L (--location) option isn't reliable at least
# with its 7.12.3 version.  Curl will forget to post data if
# there is a redirection.  This function is a workaround for
# curl.  Redirection happens on borg hosts.
sub ResolveRedirectionForCurl {
  my $url = shift;
  my $command_line = "$CURL -s --head '$url'";
  open(CMDLINE, "$command_line |") or error($command_line);
  while (<CMDLINE>) {
    if (/^Location: (.*)/) {
      $url = $1;
    }
  }
  close(CMDLINE);
  return $url;
}

# Fetch symbols from $SYMBOL_PAGE for all PC values found in profile
sub FetchSymbols {
  my $pcset = shift;

  my %seen = ();
  my @pcs = grep { !$seen{$_}++ } keys(%$pcset);  # uniq
  my $post_data = join("+", sort((map {"0x" . "$_"} @pcs)));
  open(POSTFILE, ">$main::tmpfile_sym");
  print POSTFILE $post_data;
  close(POSTFILE);

  my $url = SymbolPageURL();
  # Here we use curl for sending data via POST since old
  # wget doesn't have --post-file option.
  $url = ResolveRedirectionForCurl($url);
  my $command_line = "$CURL -sd '\@$main::tmpfile_sym' '$url'";
  # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols.
  my $cppfilt = $obj_tool_map{"c++filt"};
  open(SYMBOL, "$command_line | $cppfilt |") or error($command_line);

  my %map;
  while (<SYMBOL>) {
    # Removes all the leading zeroes from the symbols, see comment below.
    if (m/^0x0*([0-9a-f]+)\s+(.+)/) {
      $map{$1} = $2;
    }
  }
  close(SYMBOL);

  my $symbols = {};
  for my $pc (@pcs) {
    my $fullname;
    # For 64 bits binaries, symbols are extracted with 8 leading zeroes.
    # Then /symbolz reads the long symbols in as uint64, and outputs
    # the result with a "0x%08llx" format which get rid of the zeroes.
    # By removing all the leading zeroes in both $pc and the symbols from
    # /symbolz, the symbols match and are retrievable from the map.
    my $shortpc = $pc;
    $shortpc =~ s/^0*//;
    if (defined($map{$shortpc})) {
      $fullname = $map{$shortpc};
    } else {
      $fullname = "0x" . $pc;  # Just use addresses
    }
    my $name = ShortFunctionName($fullname);
    $symbols->{$pc} = [$name, "?", $fullname];
  }
  return $symbols;
}

sub BaseName {
  my $file_name = shift;
  $file_name =~ s!^.*/!!;  # Remove directory name
  return $file_name;
}

sub MakeProfileBaseName {
  my ($binary_name, $profile_name) = @_;
  my ($host, $port, $type) = ParseProfileURL($profile_name);
  my $binary_shortname = BaseName($binary_name);
  return sprintf("%s.%s.%s-port%s",
                 $binary_shortname, $main::op_time, $host, $port);
}

sub FetchDynamicProfile {
  my $binary_name = shift;
  my $profile_name = shift;
  my $fetch_name_only = shift;
  my $encourage_patience = shift;

  if (!IsProfileURL($profile_name)) {
    return $profile_name;
  } else {
    my ($host, $port, $type) = ParseProfileURL($profile_name);
    if ($type eq "" || $type eq "/") {
      # Missing type specifier defaults to cpu-profile
      $type = $PROFILE_PAGE;
    }

    my $profile_file = MakeProfileBaseName($binary_name, $profile_name);

    my $url;
    my $wget_timeout;
    if ($type eq $PROFILE_PAGE) {
      $url = sprintf("http://$host:$port$PROFILE_PAGE?seconds=%d",
                     $main::opt_seconds);
      $wget_timeout = sprintf("--timeout=%d",
                              int($main::opt_seconds * 1.01 + 60));
    } else {
      # For non-CPU profiles, we add a type-extension to
      # the target profile file name.
      my $suffix = $type;
      $suffix =~ s,/,.,g;
      $profile_file .= "$suffix";
      $url = "http://$host:$port$type";
      $wget_timeout = "";
    }

    my $profile_dir = $ENV{"PPROF_TMPDIR"} || ($ENV{HOME} . "/pprof");
    if (!(-d $profile_dir)) {
      mkdir($profile_dir)
	  || die("Unable to create profile directory $profile_dir: $!\n");
    }
    my $tmp_profile = "$profile_dir/.tmp.$profile_file";
    my $real_profile = "$profile_dir/$profile_file";

    if ($fetch_name_only > 0) {
      return $real_profile;
    }

    my $cmd = "$WGET $wget_timeout -q -O $tmp_profile '$url'";
    if ($type eq $PROFILE_PAGE) {
      print STDERR "Gathering CPU profile from $host:$port for $main::opt_seconds seconds to\n  ${real_profile}\n";
      if ($encourage_patience) {
        print STDERR "Be patient...\n";
      }
    } else {
      print STDERR "Fetching $type profile from $host:$port to\n  ${real_profile}\n";
    }

    (system($cmd) == 0) || error("Failed to get profile: $cmd: $!\n");
    (system("mv $tmp_profile $real_profile") == 0) || error("Unable to rename profile\n");
    print STDERR "Wrote profile to $real_profile\n";
    $main::collected_profile = $real_profile;
    return $main::collected_profile;
  }
}

# Collect profiles in parallel
sub FetchDynamicProfiles {
  my $items = scalar(@main::pfile_args);
  my $levels = log($items) / log(2);

  if ($items == 1) {
    $main::profile_files[0] = FetchDynamicProfile($main::prog, $main::pfile_args[0], 0, 1);
  } else {
    # math rounding issues
    if ((2 ** $levels) < $items) {
     $levels++;
    }
    my $count = scalar(@main::pfile_args);
    for (my $i = 0; $i < $count; $i++) {
      $main::profile_files[$i] = FetchDynamicProfile($main::prog, $main::pfile_args[$i], 1, 0);
    }
    print STDERR "Fetching $count profiles, Be patient...\n";
    FetchDynamicProfilesRecurse($levels, 0, 0);
    $main::collected_profile = join(" \\\n    ", @main::profile_files);
  }
}

# Recursively fork a process to get enough processes
# collecting profiles
sub FetchDynamicProfilesRecurse {
  my $maxlevel = shift;
  my $level = shift;
  my $position = shift;

  if (my $pid = fork()) {
    $position = 0 | ($position << 1);
    TryCollectProfile($maxlevel, $level, $position);
    wait;
  } else {
    $position = 1 | ($position << 1);
    TryCollectProfile($maxlevel, $level, $position);
    exit(0);
  }
}

# Collect a single profile
sub TryCollectProfile {
  my $maxlevel = shift;
  my $level = shift;
  my $position = shift;

  if ($level >= ($maxlevel - 1)) {
    if ($position < scalar(@main::pfile_args)) {
      FetchDynamicProfile($main::prog, $main::pfile_args[$position], 0, 0);
    }
  } else {
    FetchDynamicProfilesRecurse($maxlevel, $level+1, $position);
  }
}

##### Parsing code #####

# Parse profile generated by common/profiler.cc and return a reference
# to a map:
#      $result->{version}     Version number of profile file
#      $result->{period}      Sampling period (in microseconds)
#      $result->{profile}     Profile object
#      $result->{map}         Memory map info from profile
#      $result->{pcs}         Hash of all PC values seen, key is hex address
sub ReadProfile {
  my $prog = shift;
  my $fname = shift;

  $main::profile_type = '';

  # Look at first line to see if it is a heap or a CPU profile
  open(PROFILE, "<$fname") || error("$fname: $!\n");
  binmode PROFILE;      # New perls do UTF-8 processing
  my $header = <PROFILE>;
  my $contention_marker = substr($CONTENTION_PAGE, 1);   # remove leading /
  if ($header =~ m/^heap profile:.*growthz/) {
    $main::profile_type = 'growth';
    return ReadHeapProfile($prog, $fname, $header);
  } elsif ($header =~ m/^heap profile:/) {
    $main::profile_type = 'heap';
    return ReadHeapProfile($prog, $fname, $header);
  } elsif ($header =~ m/^--- *$contention_marker/o ) {
    $main::profile_type = 'contention';
    return ReadSynchProfile($prog, $fname);
  } elsif ($header =~ m/^--- *Stacks:/ ) {
    print STDERR
      "Old format contention profile: mistakenly reports " .
      "condition variable signals as lock contentions.\n";
    $main::profile_type = 'contention';
    return ReadSynchProfile($prog, $fname);
  } else {
    # Need to unread the line we just read
    $main::profile_type = 'cpu';
    close(PROFILE);
    open(PROFILE, "<$fname") || error("$fname: $!\n");
    binmode PROFILE;    # New perls do UTF-8 processing
    return ReadCPUProfile($prog, $fname);
  }
}

# CPU profile reader
sub ReadCPUProfile {
  my $prog = shift;
  my $fname = shift;

  # Read entire profile into a string
  my $str;
  my $nbytes = read(PROFILE, $str, (stat PROFILE)[7]);   # read entire file
  close(PROFILE);

  my $version;
  my $period;
  my $i;
  my $profile = {};
  my $pcs = {};

  # Parse string into array of slots.
  # L! cannot be used because with a native 64-bit build, it will cause
  # 1) a valid 64-bit profile to use the 32-bit codepath, and
  # 2) a valid 32-bit profile to be unrecognized.

  my @slots = unpack("L*", $str);

  # Read header.  The current header version is a 5-element structure
  # containing:
  #   0: header count (always 0)
  #   1: header "words" (after this one: 3)
  #   2: format version (0)
  #   3: sampling period (usec)
  #   4: unused padding (always 0)
  # The header words are 32-bit or 64-bit depending on the ABI of the program
  # that generated the profile.  In the 64-bit case, since our x86-architecture
  # machines are little-endian, the actual value of each of these elements is
  # in the first 32-bit word, and the second is always zero.  The @slots array
  # above was read as a sequence of 32-bit words in both cases, so we need to
  # explicitly check for both cases.  A typical slot sequence for each is:
  #   32-bit:  0 3 0 100 0
  #   64-bit:  0 0  3 0  0 0  100 0  0 0
  #
  if ($#slots < 4 || $slots[0] != 0 ) {
    error("$fname: not a profile file, or old format profile file\n");
  }
  if ($slots[1] >= 3) {
    # Normal 32-bit header:
    $version = $slots[2];
    $period = $slots[3];
    $i = 2 + $slots[1];
    $address_length = 8;

    # Parse profile
    while ($i <= $#slots) {
      my $n = $slots[$i++];
      my $d = $slots[$i++];
      if ($slots[$i] == 0) {
        # End of profile data marker
        $i += $d;
        last;
      }

      # Make key out of the stack entries
      my @k = ();
      for (my $j = 0; $j < $d; $j++) {
        my $pc = sprintf("%08x", $slots[$i+$j]);
        $pcs->{$pc} = 1;
        push @k, $pc;
      }

      AddEntry($profile, (join "\n", @k), $n);
      $i += $d;
    }

  # Normal 64-bit header:  All entries are doubled in size.  The first
  # word (little-endian) should contain the real value, the second should
  # be zero.
  } elsif ($#slots < 9 || $slots[1] != 0 || $slots[2] < 3 || $slots[3] != 0
        || $slots[5] != 0 || $slots[7] != 0) {
      error("$fname: not a profile file, or old format profile file\n");
  } else {
    $version = $slots[4];
    $period = $slots[6];
    $i = 4 + 2 * $slots[2];
    $address_length = 16;

    # Parse profile
    while ($i <= $#slots) {
      my $n = $slots[$i++];
      my $nhi = $slots[$i++];
      # Huge counts may coerce to floating point, keeping scale, not precision
      if ($nhi != 0) { $n += $nhi*(2**32); }
      my $d = $slots[$i++];
      if ($slots[$i++] != 0) {
        my $addr = sprintf("%o", 4 * $i);
        print STDERR "At index $i ($addr):\n";
        error("$fname: stack trace depth >= 2**32\n");
      }
      if ($slots[$i] == 0 && $slots[$i+1] == 0) {
        # End of profile data marker
        $i += 2 * $d;
        last;
      }

      # Make key out of the stack entries
      my @k = ();
      for (my $j = $d; $j--; ) {
        my $pclo = $slots[$i++];
        my $pchi = $slots[$i++];
        my $pc = sprintf("%08x%08x", $pchi, $pclo);
        $pcs->{$pc} = 1;
        push @k, $pc;
      }
      AddEntry($profile, (join "\n", @k), $n);
    }
  }

  # Parse map
  my $map = substr($str, $i * 4);

  my $r = {};
  $r->{version} = $version;
  $r->{period} = $period;
  $r->{profile} = $profile;
  $r->{libs} = ParseLibraries($prog, $map, $pcs);
  $r->{pcs} = $pcs;

  return $r;
}

sub ReadHeapProfile {
  my $prog = shift;
  my $fname = shift;
  my $header = shift;

  my $index = 1;
  if ($main::opt_inuse_space) {
    $index = 1;
  } elsif ($main::opt_inuse_objects) {
    $index = 0;
  } elsif ($main::opt_alloc_space) {
    $index = 3;
  } elsif ($main::opt_alloc_objects) {
    $index = 2;
  }

  # Find the type of this profile.  The header line looks like:
  #    heap profile:   1246:  8800744 [  1246:  8800744] @ <heap-url>/266053
  # There are two pairs <count: size>, the first inuse objects/space, and the
  # second allocated objects/space.  This is followed optionally by a profile
  # type, and if that is present, optionally by a sampling frequency.  The
  # interpretation of the sampling frequency is that the profiler, for each
  # sample, calculates a uniformly distributed random integer less than the
  # given value, and records the next sample after that many bytes have been
  # allocated.  Therefore, the expected sample interval is half of the given
  # frequency.  By default, if not specified, the expected sample interval is
  # 128KB.  Only remote-heap-page profiles are adjusted for sample size.
  my $should_adjust_sample = 0;
  my $sample_adjustment = 0;
  chomp($header);
  my $type = "unknown";
  if ($header =~ m"^heap profile:\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\](\s*@\s*([^/]*)(/(\d+))?)?") {
    if (defined($6) && ($6 ne '')) {
      $type = $6;
      # The regex test here is to see if type is a substring of HEAP_PAGE
      if (($HEAP_PAGE =~ /$type/)) {
	$should_adjust_sample = 1;
	if (defined($8) && ($8 ne '')) {
	  $sample_adjustment = int($8)/2;
	  printf STDERR ("Adjusting heap profiles for 1-in-%d sampling rate\n",
			 $sample_adjustment);
	}
      }
    } else {
      # We detect whether or not this is a remote-heap profile by checking
      # that the total-allocated stats ($n2,$s2) are exactly the
      # same as the in-use stats ($n1,$s1).  It is remotely conceivable
      # that a non-remote-heap profile may pass this check, but it is hard
      # to imagine how that could happen.
      my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);
      if (($n1 == $n2) && ($s1 == $s2)) {
        # This is likely to be a remote-heap based sample profile
	$should_adjust_sample = 1;
      }
    }
  }

  # For remote-heap generated profiles, adjust the counts and sizes to
  # account for the sample rate (we sample once every 128KB by default).
  if ($should_adjust_sample && ($sample_adjustment == 0)) {
    # Turn on profile adjustment.
    $sample_adjustment = 128*1024;
    print STDERR "Adjusting heap profiles for 1-in-128KB sampling rate\n";
  }

  my $profile = {};
  my $pcs = {};
  my $map = "";

  while (<PROFILE>) {
    if (/^MAPPED_LIBRARIES:/) {
      # Read the /proc/self/maps data
      while (<PROFILE>) {
        $map .= $_;
      }
      last;
    }

    if (/^--- Memory map:/) {
      # Read /proc/self/maps data as formatted by DumpAddressMap()
      my $buildvar = "";
      while (<PROFILE>) {
        # Parse "build=<dir>" specification if supplied
        if (m/^\s*build=(.*)\n/) {
          $buildvar = $1;
        }

        # Expand "$build" variable if available
        $_ =~ s/\$build\b/$buildvar/g;

        $map .= $_;
      }
      last;
    }

    # Read entry of the form:
    #  <count1>: <bytes1> [<count2>: <bytes2>] @ a1 a2 a3 ... an
    s/^\s*//;
    s/\s*$//;
    if (m/^\s*(\d+):\s+(\d+)\s+\[\s*(\d+):\s+(\d+)\]\s+@\s+(.*)$/) {
      my $stack = $5;
      my ($n1, $s1, $n2, $s2) = ($1, $2, $3, $4);

      if ($sample_adjustment) {
        my $ratio;
        $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
        if ($ratio < 1) {
          $n1 /= $ratio;
          $s1 /= $ratio;
        }
        $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
        if ($ratio < 1) {
          $n2 /= $ratio;
          $s2 /= $ratio;
        }
      }

      my @counts = ($n1, $s1, $n2, $s2);
      AddEntries($profile, $pcs, $stack, $counts[$index]);
    }
  }

  my $r = {};
  $r->{version} = "heap";
  $r->{period} = 1;
  $r->{profile} = $profile;
  $r->{libs} = ParseLibraries($prog, $map, $pcs);
  $r->{pcs} = $pcs;
  return $r;
}

sub ReadSynchProfile {
  my ($prog, $fname, $header) = @_;

  my $map = '';
  my $profile = {};
  my $pcs = {};
  my $sampling_period = 1;
  my $cyclespernanosec = 2.8;	# Default assumption for old binaries
  my $seen_clockrate = 0;
  my $line;

  my $index = 0;
  if ($main::opt_total_delay) {
    $index = 0;
  } elsif ($main::opt_contentions) {
    $index = 1;
  } elsif ($main::opt_mean_delay) {
    $index = 2;
  }

  while ( $line = <PROFILE> ) {
    if ( $line =~ /^\s*(\d+)\s+(\d+) \@\s*(.*?)\s*$/ ) {
      my ($cycles, $count, $stack) = ($1, $2, $3);

      # Convert cycles to nanoseconds
      $cycles /= $cyclespernanosec;

      # Adjust for sampling done by application
      $cycles *= $sampling_period;
      $count *= $sampling_period;

      my @values = ($cycles, $count, $cycles / $count);
      AddEntries($profile, $pcs, $stack, $values[$index]);

    } elsif ( $line =~ /^(slow release).*thread \d+  \@\s*(.*?)\s*$/ ||
              $line =~ /^\s*(\d+) \@\s*(.*?)\s*$/ ) {
      my ($cycles, $stack) = ($1, $2);
      if ($cycles !~ /^\d+$/) {
        next;
      }

      # Convert cycles to nanoseconds
      $cycles /= $cyclespernanosec;

      # Adjust for sampling done by application
      $cycles *= $sampling_period;

      AddEntries($profile, $pcs, $stack, $cycles);

    } elsif ( $line =~ m/^([^=]*)=(.*)$/ ) {
      my ($variable, $value) = ($1,$2);
      for ($variable, $value) {
        s/^\s+//;
        s/\s+$//;
      }
      if($variable eq "cycles/second") {
        $cyclespernanosec = $value / 1e9;
        $seen_clockrate = 1;
      } elsif ($variable eq "sampling period") {
        $sampling_period = $value;
      } elsif ($variable eq "ms since reset") {
        # Currently nothing is done with this value in pprof
        # So we just silently ignore it for now
      } elsif ($variable eq "discarded samples") {
        # Currently nothing is done with this value in pprof
        # So we just silently ignore it for now
      } else {
        printf STDERR ("Ignoring unnknown variable in /contentionz output: " .
                       "'%s' = '%s'\n",$variable,$value);
      }
    } else {
      # Memory map entry
      $map .= $line;
    }
  }
  close PROFILE;

  if (!$seen_clockrate) {
    printf STDERR ("No cycles/second entry in profile; Guessing %.1f GHz\n",
                   $cyclespernanosec);
  }

  my $r = {};
  $r->{version} = 0;
  $r->{period} = $sampling_period;
  $r->{profile} = $profile;
  $r->{libs} = ParseLibraries($prog, $map, $pcs);
  $r->{pcs} = $pcs;
  return $r;
}

# Given a hex value in the form "0x1abcd" return "0001abcd" or
# "000000000001abcd", depending on the current address length.
# There's probably a more idiomatic (or faster) way to do this...
sub HexExtend {
  my $addr = shift;

  $addr =~ s/^0x//;
  return substr("000000000000000".$addr, -$address_length);
}

##### Symbol extraction #####

# Aggressively search the lib_prefix values for the given library
# If all else fails, just return the name of the library unmodified.
# If the lib_prefix is "/my/path,/other/path" and $file is "/lib/dir/mylib.so"
# it will search the following locations in this order, until it finds a file:
#   /my/path/lib/dir/mylib.so
#   /other/path/lib/dir/mylib.so
#   /my/path/dir/mylib.so
#   /other/path/dir/mylib.so
#   /my/path/mylib.so
#   /other/path/mylib.so
#   /lib/dir/mylib.so              (returned as last resort)
sub FindLibrary {
  my $file = shift;
  my $suffix = $file;

  # Search for the library as described above
  do {
    foreach my $prefix (@prefix_list) {
      my $fullpath = $prefix . $suffix;
      if (-e $fullpath) {
        return $fullpath;
      }
    }
  } while ($suffix =~ s|^/[^/]+/|/|);
  return $file;
}

# Parse text section header of a library using objdump
sub ParseTextSectionHeader {
   my $lib = shift;

   my $size = undef;
   my $vma;
   my $file_offset;
   # Get objdump output from the library file to figure out how to
   # map between mapped addresses and addresses in the library.
   my $objdump = $obj_tool_map{"objdump"};
   open(OBJDUMP, "$objdump -h $lib |")
                 || error("$objdump $lib: $!\n");
   while (<OBJDUMP>) {
     # Idx Name          Size      VMA       LMA       File off  Algn
     #  10 .text         00104b2c  420156f0  420156f0  000156f0  2**4
     # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file
     # offset may still be 8.  But AddressSub below will still handle that.
     my @x = split;
     if (($#x >= 6) && ($x[1] eq '.text')) {
       $size = $x[2];
       $vma = $x[3];
       $file_offset = $x[5];
       last;
     }
   }
   close(OBJDUMP);

   if (!defined($size)) {
      return undef;
   }

   my $r = {};
   $r->{size} = $size;
   $r->{vma} = $vma;
   $r->{file_offset} = $file_offset;

   return $r;
}

# Split /proc/pid/maps dump into a list of libraries
sub ParseLibraries {
  return if $main::use_symbol_page;  # We don't need libraries info.
  my $prog = shift;
  my $map = shift;
  my $pcs = shift;

  my $result = [];
  my $h = "[a-f0-9]+";
  my $zero_offset = HexExtend("0");

  my $buildvar = "";
  foreach my $l (split("\n", $map)) {
    if ($l =~ m/^\s*build=(.*)$/) {
      $buildvar = $1;
    }

    my $start;
    my $finish;
    my $offset;
    my $lib;
    if ($l =~ /^($h)-($h)\s+..x.\s+($h)\s+\S+:\S+\s+\d+\s+(\S+\.so(\.\d+)*\w*)/) {
      # Full line from /proc/self/maps.  Example:
      #   40000000-40015000 r-xp 00000000 03:01 12845071   /lib/ld-2.3.2.so
      $start = HexExtend($1);
      $finish = HexExtend($2);
      $offset = HexExtend($3);
      $lib = $4;
    } elsif ($l =~ /^\s*($h)-($h):\s*(\S+\.so(\.\d+)*)/) {
      # Cooked line from DumpAddressMap.  Example:
      #   40000000-40015000: /lib/ld-2.3.2.so
      $start = HexExtend($1);
      $finish = HexExtend($2);
      $offset = $zero_offset;
      $lib = $3;
    } else {
      next;
    }

    # Expand "$build" variable if available
    $lib =~ s/\$build\b/$buildvar/g;

    $lib = FindLibrary($lib);

    my $text = ParseTextSectionHeader($lib);
    if (defined($text)) {
       my $vma_offset = AddressSub($text->{vma}, $text->{file_offset});
       $offset = AddressAdd($offset, $vma_offset);
    }

    push(@{$result}, [$lib, $start, $finish, $offset]);
  }

  # Append special entry for additional library (not relocated)
  if ($main::opt_lib ne "") {
    my $text = ParseTextSectionHeader($main::opt_lib);
    if (defined($text)) {
       my $start = $text->{vma};
       my $finish = AddressAdd($start, $text->{size});

       push(@{$result}, [$main::opt_lib, $start, $finish, $start]);
    }
  }

  # Append special entry for the main program
  my $max_pc = "0";
  foreach my $pc (keys(%{$pcs})) {
    if ($pc gt $max_pc) { $max_pc = $pc; }
  }
  push(@{$result}, [$prog, $zero_offset, $max_pc, $zero_offset]);

  return $result;
}

# Add two hex addresses of length $address_length.
# Run pprof --test for unit test if this is changed.
sub AddressAdd {
  my $addr1 = shift;
  my $addr2 = shift;
  my $sum;

  if ($address_length == 8) {
    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
    $sum = (hex($addr1)+hex($addr2)) % (0x10000000 * 16);
    return sprintf("%08x", $sum);

  } else {
    # Do the addition in 7-nibble chunks to trivialize carry handling.

    if ($main::opt_debug and $main::opt_test) {
      print STDERR "AddressAdd $addr1 + $addr2 = ";
    }

    my $a1 = substr($addr1,-7);
    $addr1 = substr($addr1,0,-7);
    my $a2 = substr($addr2,-7);
    $addr2 = substr($addr2,0,-7);
    $sum = hex($a1) + hex($a2);
    my $c = 0;
    if ($sum > 0xfffffff) {
      $c = 1;
      $sum -= 0x10000000;
    }
    my $r = sprintf("%07x", $sum);

    $a1 = substr($addr1,-7);
    $addr1 = substr($addr1,0,-7);
    $a2 = substr($addr2,-7);
    $addr2 = substr($addr2,0,-7);
    $sum = hex($a1) + hex($a2) + $c;
    $c = 0;
    if ($sum > 0xfffffff) {
      $c = 1;
      $sum -= 0x10000000;
    }
    $r = sprintf("%07x", $sum) . $r;

    $sum = hex($addr1) + hex($addr2) + $c;
    if ($sum > 0xff) { $sum -= 0x100; }
    $r = sprintf("%02x", $sum) . $r;

    if ($main::opt_debug and $main::opt_test) { print STDERR "$r\n"; }

    return $r;
  }
}


# Subtract two hex addresses of length $address_length.
# Run pprof --test for unit test if this is changed.
sub AddressSub {
  my $addr1 = shift;
  my $addr2 = shift;
  my $diff;

  if ($address_length == 8) {
    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
    $diff = (hex($addr1)-hex($addr2)) % (0x10000000 * 16);
    return sprintf("%08x", $diff);

  } else {
    # Do the addition in 7-nibble chunks to trivialize borrow handling.
    # if ($main::opt_debug) { print STDERR "AddressSub $addr1 - $addr2 = "; }

    my $a1 = hex(substr($addr1,-7));
    $addr1 = substr($addr1,0,-7);
    my $a2 = hex(substr($addr2,-7));
    $addr2 = substr($addr2,0,-7);
    my $b = 0;
    if ($a2 > $a1) {
      $b = 1;
      $a1 += 0x10000000;
    }
    $diff = $a1 - $a2;
    my $r = sprintf("%07x", $diff);

    $a1 = hex(substr($addr1,-7));
    $addr1 = substr($addr1,0,-7);
    $a2 = hex(substr($addr2,-7)) + $b;
    $addr2 = substr($addr2,0,-7);
    $b = 0;
    if ($a2 > $a1) {
      $b = 1;
      $a1 += 0x10000000;
    }
    $diff = $a1 - $a2;
    $r = sprintf("%07x", $diff) . $r;

    $a1 = hex($addr1);
    $a2 = hex($addr2) + $b;
    if ($a2 > $a1) { $a1 += 0x100; }
    $diff = $a1 - $a2;
    $r = sprintf("%02x", $diff) . $r;

    # if ($main::opt_debug) { print STDERR "$r\n"; }

    return $r;
  }
}

# Increment a hex addresses of length $address_length.
# Run pprof --test for unit test if this is changed.
sub AddressInc {
  my $addr = shift;
  my $sum;

  if ($address_length == 8) {
    # Perl doesn't cope with wraparound arithmetic, so do it explicitly:
    $sum = (hex($addr)+1) % (0x10000000 * 16);
    return sprintf("%08x", $sum);

  } else {
    # Do the addition in 7-nibble chunks to trivialize carry handling.
    # We are always doing this to step through the addresses in a function,
    # and will almost never overflow the first chunk, so we check for this
    # case and exit early.

    # if ($main::opt_debug) { print STDERR "AddressInc $addr1 = "; }

    my $a1 = substr($addr,-7);
    $addr = substr($addr,0,-7);
    $sum = hex($a1) + 1;
    my $r = sprintf("%07x", $sum);
    if ($sum <= 0xfffffff) {
      $r = $addr . $r;
      # if ($main::opt_debug) { print STDERR "$r\n"; }
      return HexExtend($r);
    } else {
      $r = "0000000";
    }

    $a1 = substr($addr,-7);
    $addr = substr($addr,0,-7);
    $sum = hex($a1) + 1;
    $r = sprintf("%07x", $sum) . $r;
    if ($sum <= 0xfffffff) {
      $r = $addr . $r;
      # if ($main::opt_debug) { print STDERR "$r\n"; }
      return HexExtend($r);
    } else {
      $r = "00000000000000";
    }

    $sum = hex($addr) + 1;
    if ($sum > 0xff) { $sum -= 0x100; }
    $r = sprintf("%02x", $sum) . $r;

    # if ($main::opt_debug) { print STDERR "$r\n"; }
    return $r;
  }
}

# Extract symbols for all PC values found in profile
sub ExtractSymbols {
  my $libs = shift;
  my $profile = shift;
  my $pcset = shift;

  my $symbols = {};

  # Map each PC value to the containing library
  my %seen = ();
  foreach my $lib (@{$libs}) {
    my $libname = $lib->[0];
    my $start = $lib->[1];
    my $finish = $lib->[2];
    my $offset = $lib->[3];

    # Get list of pcs that belong in this library.
    my $contained = [];
    foreach my $pc (keys(%{$pcset})) {
      if (!$seen{$pc} && ($pc ge $start) && ($pc le $finish)) {
        $seen{$pc} = 1;
        push(@{$contained}, $pc);
      }
    }
    # Map to symbols
    MapToSymbols($libname, AddressSub($start, $offset), $contained, $symbols);
  }

  return $symbols;
}

# Map list of PC values to symbols for a given image
sub MapToSymbols {
  my $image = shift;
  my $offset = shift;
  my $pclist = shift;
  my $symbols = shift;

  # Ignore empty binaries
  if ($#{$pclist} < 0) { return; }

  my $got_symbols = MapSymbolsWithNM($image, $offset, $pclist, $symbols);
  if ($main::opt_interactive ||
      $main::opt_addresses   ||
      $main::opt_lines       ||
      $main::opt_files       ||
      $main::opt_list        ||
      !$got_symbols) {
    GetLineNumbers($image, $offset, $pclist, $symbols);
  }
}

sub GetLineNumbers {
  my $image = shift;
  my $offset = shift;
  my $pclist = shift;
  my $symbols = shift;

  # Make file with all PC values
  open(ADDRESSES, ">$main::tmpfile_sym") || error("$main::tmpfile_sym: $!\n");
  for (my $i = 0; $i <= $#{$pclist}; $i++) {
    # addr2line always reads hex addresses, and does not need '0x' prefix.
    printf ADDRESSES ("%s\n", AddressSub($pclist->[$i], $offset));
  }
  close(ADDRESSES);

  # Pass to addr2line
  my $addr2line = $obj_tool_map{"addr2line"};
  open(SYMBOLS, "$addr2line -f -C -e $image <$main::tmpfile_sym |")
    || error("$addr2line: $!\n");
  my $count = 0;
  while (<SYMBOLS>) {
    chop;
    my $fullfunction = $_;

    $_ = <SYMBOLS>;
    chop;
    my $filelinenum = $_;
    if (!$main::opt_list) {
      $filelinenum =~ s|^.*/([^/]+:\d+)$|$1|;    # Remove directory name
    }

    my $pcstr = $pclist->[$count];
    if (defined($symbols->{$pcstr})) {
      # Override just the line-number portion.  The function name portion
      # is less buggy when computed using nm instead of addr2line.
      $symbols->{$pcstr}->[1] = $filelinenum;
    } else {
      my $function = ShortFunctionName($fullfunction);
      $symbols->{$pcstr} = [$function, $filelinenum, $fullfunction];
    }
    $count++;
  }
  close(SYMBOLS);
}

# Use nm to map the list of referenced PCs to symbols.  Return true iff we
# are able to read procedure information via nm.
sub MapSymbolsWithNM {
  my $image = shift;
  my $offset = shift;
  my $pclist = shift;
  my $symbols = shift;

  # Get nm output sorted by increasing address
  my $symbol_table = GetProcedureBoundaries($image, ".");
  if (!%{$symbol_table}) {
    return 0;
  }
  # Start addresses are already the right length (8 or 16 hex digits).
  my @names = sort { $symbol_table->{$a}->[0] cmp $symbol_table->{$b}->[0] }
    keys(%{$symbol_table});

  if ($#names < 0) {
    # No symbols: just use addresses
    foreach my $pc (@{$pclist}) {
      my $pcstr = "0x" . $pc;
      $symbols->{$pc} = [$pcstr, "?", $pcstr];
    }
    return 0;
  }

  # Sort addresses so we can do a join against nm output
  my $index = 0;
  my $fullname = $names[0];
  my $name = ShortFunctionName($fullname);
  foreach my $pc (sort { $a cmp $b } @{$pclist}) {
    # Adjust for mapped offset
    my $mpc = AddressSub($pc, $offset);
    while (($index < $#names) && ($mpc ge $symbol_table->{$fullname}->[1])){
      $index++;
      $fullname = $names[$index];
      $name = ShortFunctionName($fullname);
    }
    if ($mpc lt $symbol_table->{$fullname}->[1]) {
      $symbols->{$pc} = [$name, "?", $fullname];
    } else {
      my $pcstr = "0x" . $pc;
      $symbols->{$pc} = [$pcstr, "?", $pcstr];
    }
  }
  return 1;
}

sub ShortFunctionName {
  my $function = shift;
  while ($function =~ s/\([^()]*\)(\s*const)?//g) { }   # Argument types
  while ($function =~ s/<[^<>]*>//g)  { }    # Remove template arguments
  $function =~ s/^.*\s+(\w+::)/$1/;          # Remove leading type
  return $function;
}

##### Miscellaneous #####

# Find the right versions of the above object tools to use.  The argument
# is the program file being analyzed, and should be an ELF 32-bit or ELF
# 64-bit executable file.  If it is, we select the default tools location
# based on that; otherwise, we'll emit a warning and take the user's
# defaults.
sub ConfigureObjTools {
  my $prog_file = shift;

  # Figure out the right default pathname prefix based on the program file
  # type:
  my $default_prefix = "/usr/bin/";
  # Follow symlinks (at least for systems where "file" supports that)
  my $file_type = `/usr/bin/file -L $prog_file 2>/dev/null || /usr/bin/file $prog_file`;
  if ($file_type !~ /executable/) {
    warn "WARNING: program $prog_file is apparently not an executable\n";
    # Don't change the default prefix.
  } elsif ($file_type =~ /64-bit/) {
    # Change $address_length to 16 if the program file is ELF 64-bit.
    # We can't detect this from many (most?) heap or lock contention
    # profiles, since the actual addresses referenced are generally in low
    # memory even for 64-bit programs.
    $address_length = 16;
  }

  # Go fill in %obj_tool_map with the pathnames to use:
  foreach my $tool (keys %obj_tool_map) {
    $obj_tool_map{$tool} = ConfigureTool($obj_tool_map{$tool},
					 $default_prefix);
  }
}

sub ConfigureTool {
  my $tool = shift;
  my $prefix = shift;
  my $path;

  if ($main::opt_debug) {
    print STDERR "Configuring '$tool' with default prefix '$prefix'\n";
  }

  # Try a specific prefix specified by the user:
  if ($main::opt_tools ne "") {
    $path = $main::opt_tools . $tool;
    if ($main::opt_debug) { print STDERR "  (a) Trying '$path'\n"; }
    if (-x $path) { return $path; }
  }

  # Try the default prefix passed to us:
  $path = $prefix . $tool;
  if ($main::opt_debug) { print STDERR "  (b) Trying '$path'\n"; }
  if (-x $path) { return $path; }

  # Try the normal system default (/usr/bin/):
  if ($prefix ne "/usr/bin/") {
    $path = "/usr/bin/$tool";
    if ($main::opt_debug) { print STDERR "  (c) Trying '$path'\n"; }
    if (-x $path) { return $path; }
  }

  # If all else fails, hope the bare toolname works:
  if ($main::opt_debug) { print STDERR "  Returning '$tool'\n"; }
  return $tool;
}

sub cleanup {
  unlink($main::tmpfile_sym);
  for (my $i = 0; $i < $main::next_tmpfile; $i++) {
    unlink(PsTempName($i));
  }
  # We leave any collected profiles in $HOME/pprof in case the user wants
  # to look at them later.  We print a message informing them of this.
  if ((scalar(@main::profile_files) > 0) &&
      defined($main::collected_profile)) {
    if (scalar(@main::profile_files) == 1) {
      print STDERR "Dynamically gathered profile is in $main::collected_profile\n";
    }
    print STDERR "If you want to investigate this profile further, you can do:\n";
    print STDERR "\n";
    print STDERR "  pprof \\\n";
    print STDERR "    $main::prog \\\n";
    print STDERR "    $main::collected_profile\n";
    print STDERR "\n";
  }
}

sub sighandler {
  cleanup();
  exit(1);
}

sub error {
  my $msg = shift;
  print STDERR $msg;
  cleanup();
  exit(1);
}


# Run $nm_command and get all the resulting procedure boundaries whose
# names match "$regexp" and returns them in a hashtable mapping from
# procedure name to a two-element vector of [start address, end address]
sub GetProcedureBoundariesViaNm {
  my $nm_command = shift;
  my $regexp = shift;

  my $symbol_table = {};
  open(NM, "$nm_command |") || error("$nm_command: $!\n");
  my $last_start = "0";
  my $routine = "";
  while (<NM>) {
    if (m/^([0-9a-f]+) . (..*)/) {
      my $start_val = $1;
      my $this_routine = $2;
      if (defined($routine) && $routine =~ m/$regexp/) {
        $symbol_table->{$routine} = [HexExtend($last_start),
				     HexExtend($start_val)];
      }
      $last_start = $start_val;
      $routine = $this_routine;
    }
  }
  close(NM);

  return $symbol_table;
}

# Gets the procedure boundaries for all routines in "$image" whose names
# match "$regexp" and returns them in a hashtable mapping from procedure
# name to a two-element vector of [start address, end address].
# Will return an empty map if nm is not installed or not working properly.
sub GetProcedureBoundaries {
  my $image = shift;
  my $regexp = shift;

  # For libc libraries, the copy in /usr/lib/debug contains debugging symbols
  if ($image =~ m|^/| && -f "/usr/lib/debug$image") {
    $image = "/usr/lib/debug$image";
  }
  my $nm = $obj_tool_map{"nm"};
  my $cppfilt = $obj_tool_map{"c++filt"};

  # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm
  # binary doesn't support --demangle.  For the first, we try with -D
  # to at least get *exported* symbols.  For the second, we use c++filt
  # instead of --demangle.  (c++filt is less reliable though, because it
  # might interpret nm meta-data as c++ symbols and try to demangle it :-/)
  foreach my $nm_command ("$nm -n --demangle $image 2>/dev/null",
			  "$nm -n $image 2>&1 | $cppfilt",
			  "$nm -D -n --demangle $image 2>/dev/null",
			  "$nm -D -n $image 2>&1 | $cppfilt",
			  "$nm -n $image 2>/dev/null",
			  "$nm -D -n $image 2>/dev/null") {
    my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp);
    return $symbol_table if (%{$symbol_table});
  }
  my $symbol_table = {};
  return $symbol_table;
}


# The test vectors for AddressAdd/Sub/Inc are 8-16-nibble hex strings.
# To make them more readable, we add underscores at interesting places.
# This routine removes the underscores, producing the canonical representation
# used by pprof to represent addresses, particularly in the tested routines.
sub CanonicalHex {
  my $arg = shift;
  return join '', (split '_',$arg);
}


# Unit test for AddressAdd:
sub AddressAddUnitTest {
  my $test_data_8 = shift;
  my $test_data_16 = shift;
  my $error_count = 0;
  my $fail_count = 0;
  my $pass_count = 0;
  # print STDERR "AddressAddUnitTest: ", 1+$#{$test_data_8}, " tests\n";

  # First a few 8-nibble addresses.  Note that this implementation uses
  # plain old arithmetic, so a quick sanity check along with verifying what
  # happens to overflow (we want it to wrap):
  $address_length = 8;
  foreach my $row (@{$test_data_8}) {
    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
    my $sum = AddressAdd ($row->[0], $row->[1]);
    if ($sum ne $row->[2]) {
      printf STDERR "ERROR: %s != %s + %s = %s\n", $sum,
             $row->[0], $row->[1], $row->[2];
      ++$fail_count;
    } else {
      ++$pass_count;
    }
  }
  printf STDERR "AddressAdd 32-bit tests: %d passes, %d failures\n",
         $pass_count, $fail_count;
  $error_count = $fail_count;
  $fail_count = 0;
  $pass_count = 0;

  # Now 16-nibble addresses.
  $address_length = 16;
  foreach my $row (@{$test_data_16}) {
    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
    my $sum = AddressAdd (CanonicalHex($row->[0]), CanonicalHex($row->[1]));
    my $expected = join '', (split '_',$row->[2]);
    if ($sum ne CanonicalHex($row->[2])) {
      printf STDERR "ERROR: %s != %s + %s = %s\n", $sum,
             $row->[0], $row->[1], $row->[2];
      ++$fail_count;
    } else {
      ++$pass_count;
    }
  }
  printf STDERR "AddressAdd 64-bit tests: %d passes, %d failures\n",
         $pass_count, $fail_count;
  $error_count += $fail_count;

  return $error_count;
}


# Unit test for AddressSub:
sub AddressSubUnitTest {
  my $test_data_8 = shift;
  my $test_data_16 = shift;
  my $error_count = 0;
  my $fail_count = 0;
  my $pass_count = 0;
  # print STDERR "AddressSubUnitTest: ", 1+$#{$test_data_8}, " tests\n";

  # First a few 8-nibble addresses.  Note that this implementation uses
  # plain old arithmetic, so a quick sanity check along with verifying what
  # happens to overflow (we want it to wrap):
  $address_length = 8;
  foreach my $row (@{$test_data_8}) {
    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
    my $sum = AddressSub ($row->[0], $row->[1]);
    if ($sum ne $row->[3]) {
      printf STDERR "ERROR: %s != %s - %s = %s\n", $sum,
             $row->[0], $row->[1], $row->[3];
      ++$fail_count;
    } else {
      ++$pass_count;
    }
  }
  printf STDERR "AddressSub 32-bit tests: %d passes, %d failures\n",
         $pass_count, $fail_count;
  $error_count = $fail_count;
  $fail_count = 0;
  $pass_count = 0;

  # Now 16-nibble addresses.
  $address_length = 16;
  foreach my $row (@{$test_data_16}) {
    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
    my $sum = AddressSub (CanonicalHex($row->[0]), CanonicalHex($row->[1]));
    if ($sum ne CanonicalHex($row->[3])) {
      printf STDERR "ERROR: %s != %s - %s = %s\n", $sum,
             $row->[0], $row->[1], $row->[3];
      ++$fail_count;
    } else {
      ++$pass_count;
    }
  }
  printf STDERR "AddressSub 64-bit tests: %d passes, %d failures\n",
         $pass_count, $fail_count;
  $error_count += $fail_count;

  return $error_count;
}


# Unit test for AddressInc:
sub AddressIncUnitTest {
  my $test_data_8 = shift;
  my $test_data_16 = shift;
  my $error_count = 0;
  my $fail_count = 0;
  my $pass_count = 0;
  # print STDERR "AddressIncUnitTest: ", 1+$#{$test_data_8}, " tests\n";

  # First a few 8-nibble addresses.  Note that this implementation uses
  # plain old arithmetic, so a quick sanity check along with verifying what
  # happens to overflow (we want it to wrap):
  $address_length = 8;
  foreach my $row (@{$test_data_8}) {
    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
    my $sum = AddressInc ($row->[0]);
    if ($sum ne $row->[4]) {
      printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum,
             $row->[0], $row->[4];
      ++$fail_count;
    } else {
      ++$pass_count;
    }
  }
  printf STDERR "AddressInc 32-bit tests: %d passes, %d failures\n",
         $pass_count, $fail_count;
  $error_count = $fail_count;
  $fail_count = 0;
  $pass_count = 0;

  # Now 16-nibble addresses.
  $address_length = 16;
  foreach my $row (@{$test_data_16}) {
    if ($main::opt_debug and $main::opt_test) { print STDERR "@{$row}\n"; }
    my $sum = AddressInc (CanonicalHex($row->[0]));
    if ($sum ne CanonicalHex($row->[4])) {
      printf STDERR "ERROR: %s != %s + 1 = %s\n", $sum,
             $row->[0], $row->[4];
      ++$fail_count;
    } else {
      ++$pass_count;
    }
  }
  printf STDERR "AddressInc 64-bit tests: %d passes, %d failures\n",
         $pass_count, $fail_count;
  $error_count += $fail_count;

  return $error_count;
}


# Driver for unit tests.
# Currently just the address add/subtract/increment routines for 64-bit.
sub RunUnitTests {
  my $error_count = 0;

  # This is a list of tuples [a, b, a+b, a-b, a+1]
  my $unit_test_data_8 = [
    [qw(aaaaaaaa 50505050 fafafafa 5a5a5a5a aaaaaaab)],
    [qw(50505050 aaaaaaaa fafafafa a5a5a5a6 50505051)],
    [qw(ffffffff aaaaaaaa aaaaaaa9 55555555 00000000)],
    [qw(00000001 ffffffff 00000000 00000002 00000002)],
    [qw(00000001 fffffff0 fffffff1 00000011 00000002)],
  ];
  my $unit_test_data_16 = [
    # The implementation handles data in 7-nibble chunks, so those are the
    # interesting boundaries.
    [qw(aaaaaaaa 50505050
        00_000000f_afafafa 00_0000005_a5a5a5a 00_000000a_aaaaaab)],
    [qw(50505050 aaaaaaaa
        00_000000f_afafafa ff_ffffffa_5a5a5a6 00_0000005_0505051)],
    [qw(ffffffff aaaaaaaa
        00_000001a_aaaaaa9 00_0000005_5555555 00_0000010_0000000)],
    [qw(00000001 ffffffff
        00_0000010_0000000 ff_ffffff0_0000002 00_0000000_0000002)],
    [qw(00000001 fffffff0
        00_000000f_ffffff1 ff_ffffff0_0000011 00_0000000_0000002)],

    [qw(00_a00000a_aaaaaaa 50505050
        00_a00000f_afafafa 00_a000005_a5a5a5a 00_a00000a_aaaaaab)],
    [qw(0f_fff0005_0505050 aaaaaaaa
        0f_fff000f_afafafa 0f_ffefffa_5a5a5a6 0f_fff0005_0505051)],
    [qw(00_000000f_fffffff 01_800000a_aaaaaaa
        01_800001a_aaaaaa9 fe_8000005_5555555 00_0000010_0000000)],
    [qw(00_0000000_0000001 ff_fffffff_fffffff
        00_0000000_0000000 00_0000000_0000002 00_0000000_0000002)],
    [qw(00_0000000_0000001 ff_fffffff_ffffff0
        ff_fffffff_ffffff1 00_0000000_0000011 00_0000000_0000002)],
  ];

  $error_count += AddressAddUnitTest($unit_test_data_8, $unit_test_data_16);
  $error_count += AddressSubUnitTest($unit_test_data_8, $unit_test_data_16);
  $error_count += AddressIncUnitTest($unit_test_data_8, $unit_test_data_16);
  if ($error_count > 0) {
    print STDERR $error_count, " errors: FAILED\n";
  } else {
    print STDERR "PASS\n";
  }
  exit ($error_count);
}