Merge google-perftools r109 (the current contents of third_party/tcmalloc/vendor)

third_party/tcmalloc/chromium/src/pprof

 #! /usr/bin/env perl
 
 # Copyright (c) 1998-2007, Google Inc.
 # All rights reserved.
 # 
 # Redistribution and use in source and binary forms, with or without
 # modification, are permitted provided that the following conditions are
 # met:
 # 
 #     * Redistributions of source code must retain the above copyright
@@ skipping 54 matching lines @@
 #   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 = "1.5";
+my $PPROF_VERSION = "1.7";
 
 # These are the object tools we use which can come from a
 # user-specified location using --tools, from the PPROF_TOOLS
 # environment variable, or from the environment.
 my %obj_tool_map = (
   "objdump" => "objdump",
   "nm" => "nm",
   "addr2line" => "addr2line",
   "c++filt" => "c++filt",
   ## ConfigureObjTools may add architecture-specific entries:
   #"nm_pdb" => "nm-pdb",       # for reading windows (PDB-format) executables
   #"addr2line_pdb" => "addr2line-pdb",                                # ditto
   #"otool" => "otool",         # equivalent of objdump on OS X
 );
 my $DOT = "dot";          # leave non-absolute, since it may be in /usr/local
 my $GV = "gv";
+my $EVINCE = "evince";    # could also be xpdf or perhaps acroread
 my $KCACHEGRIND = "kcachegrind";
 my $PS2PDF = "ps2pdf";
 # These are used for dynamic profiles
 my $URL_FETCHER = "curl -s";
 
 # These are the web pages that servers need to support for dynamic profiles
 my $HEAP_PAGE = "/pprof/heap";
 my $PROFILE_PAGE = "/pprof/profile";   # must support cgi-param "?seconds=#"
 my $PMUPROFILE_PAGE = "/pprof/pmuprofile(?:\\?.*)?"; # must support cgi-param
                                                 # ?seconds=#&event=x&period=n
 my $GROWTH_PAGE = "/pprof/growth";
 my $CONTENTION_PAGE = "/pprof/contention";
 my $WALL_PAGE = "/pprof/wall(?:\\?.*)?";  # accepts options like namefilter
 my $FILTEREDPROFILE_PAGE = "/pprof/filteredprofile(?:\\?.*)?";
+my $CENSUSPROFILE_PAGE = "/pprof/censusprofile";  # must support "?seconds=#"
 my $SYMBOL_PAGE = "/pprof/symbol";     # must support symbol lookup via POST
 my $PROGRAM_NAME_PAGE = "/pprof/cmdline";
 
+# These are the web pages that can be named on the command line.
+# All the alternatives must begin with /.
+my $PROFILES = "($HEAP_PAGE|$PROFILE_PAGE|$PMUPROFILE_PAGE|" .
+               "$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|" .
+               "$FILTEREDPROFILE_PAGE|$CENSUSPROFILE_PAGE)";
+
 # default binary name
 my $UNKNOWN_BINARY = "(unknown)";
 
 # There is a pervasive dependency on the length (in hex characters,
 # i.e., nibbles) of an address, distinguishing between 32-bit and
 # 64-bit profiles.  To err on the safe size, default to 64-bit here:
 my $address_length = 16;
 
+my $dev_null = "/dev/null";
+if (! -e $dev_null && $^O =~ /MSWin/) {    # $^O is the OS perl was built for
+  $dev_null = "nul";
+}
+
 # A list of paths to search for shared object files
 my @prefix_list = ();
 
 # Special routine name that should not have any symbols.
 # Used as separator to parse "addr2line -i" output.
 my $sep_symbol = '_fini';
 my $sep_address = undef;
 
 ##### Argument parsing #####
 
 sub usage_string {
   return <<EOF;
 Usage:
 pprof [options] <program> <profiles>
    <profiles> is a space separated list of profile names.
 pprof [options] <symbolized-profiles>
    <symbolized-profiles> is a list of profile files where each file contains
    the necessary symbol mappings  as well as profile data (likely generated
    with --raw).
 pprof [options] <profile>
    <profile> is a remote form.  Symbols are obtained from host:port$SYMBOL_PAGE
 
    Each name can be:
    /path/to/profile        - a path to a profile file
    host:port[/<service>]   - a location of a service to get profile from
 
    The /<service> can be $HEAP_PAGE, $PROFILE_PAGE, /pprof/pmuprofile,
                          $GROWTH_PAGE, $CONTENTION_PAGE, /pprof/wall,
-                         or /pprof/filteredprofile.
+                         $CENSUSPROFILE_PAGE, or /pprof/filteredprofile.
    For instance: "pprof http://myserver.com:80$HEAP_PAGE".
    If /<service> is omitted, the service defaults to $PROFILE_PAGE (cpu profiling).
 pprof --symbols <program>
    Maps addresses to symbol names.  In this mode, stdin should be a
    list of library mappings, in the same format as is found in the heap-
    and cpu-profile files (this loosely matches that of /proc/self/maps
    on linux), followed by a list of hex addresses to map, one per line.
 
    For more help with querying remote servers, including how to add the
    necessary server-side support code, see this filename (or one like it):
@@ skipping 11 matching lines @@
 Reporting Granularity:
    --addresses         Report at address level
    --lines             Report at source line level
    --functions         Report at function level [default]
    --files             Report at source file level
 
 Output type:
    --text              Generate text report
    --callgrind         Generate callgrind format to stdout
    --gv                Generate Postscript and display
+   --evince            Generate PDF and display
    --web               Generate SVG and display
    --list=<regexp>     Generate source listing of matching routines
    --disasm=<regexp>   Generate disassembly of matching routines
    --symbols           Print demangled symbol names found at given addresses
    --dot               Generate DOT file to stdout
    --ps                Generate Postcript to stdout
    --pdf               Generate PDF to stdout
    --svg               Generate SVG to stdout
    --gif               Generate GIF to stdout
    --raw               Generate symbolized pprof data (useful with remote fetch)
 
 Heap-Profile Options:
    --inuse_space       Display in-use (mega)bytes [default]
    --inuse_objects     Display in-use objects
    --alloc_space       Display allocated (mega)bytes
    --alloc_objects     Display allocated objects
    --show_bytes        Display space in bytes
    --drop_negative     Ignore negative differences
 
 Contention-profile options:
    --total_delay       Display total delay at each region [default]
    --contentions       Display number of delays at each region
    --mean_delay        Display mean delay at each region
 
 Call-graph Options:
    --nodecount=<n>     Show at most so many nodes [default=80]
    --nodefraction=<f>  Hide nodes below <f>*total [default=.005]
    --edgefraction=<f>  Hide edges below <f>*total [default=.001]
+   --maxdegree=<n>     Max incoming/outgoing edges per node [default=8]
    --focus=<regexp>    Focus on nodes matching <regexp>
    --ignore=<regexp>   Ignore nodes matching <regexp>
    --scale=<n>         Set GV scaling [default=0]
    --heapcheck         Make nodes with non-0 object counts
                        (i.e. direct leak generators) more visible
 
 Miscellaneous:
-   --tools=<prefix>    Prefix for object tool pathnames
+   --tools=<prefix or binary:fullpath>[,...]   \$PATH for object tool pathnames
    --test              Run unit tests
    --help              This message
    --version           Version information
 
 Environment Variables:
    PPROF_TMPDIR        Profiles directory. Defaults to \$HOME/pprof
    PPROF_TOOLS         Prefix for object tools pathnames
 
 Examples:
 
@@ skipping 68 matching lines @@
   $main::opt_functions = 0;
   $main::opt_files = 0;
   $main::opt_lib_prefix = "";
 
   $main::opt_text = 0;
   $main::opt_callgrind = 0;
   $main::opt_list = "";
   $main::opt_disasm = "";
   $main::opt_symbols = 0;
   $main::opt_gv = 0;
+  $main::opt_evince = 0;
   $main::opt_web = 0;
   $main::opt_dot = 0;
   $main::opt_ps = 0;
   $main::opt_pdf = 0;
   $main::opt_gif = 0;
   $main::opt_svg = 0;
   $main::opt_raw = 0;
 
   $main::opt_nodecount = 80;
   $main::opt_nodefraction = 0.005;
   $main::opt_edgefraction = 0.001;
+  $main::opt_maxdegree = 8;
   $main::opt_focus = '';
   $main::opt_ignore = '';
   $main::opt_scale = 0;
   $main::opt_heapcheck = 0;
   $main::opt_seconds = 30;
   $main::opt_lib = "";
 
   $main::opt_inuse_space   = 0;
   $main::opt_inuse_objects = 0;
   $main::opt_alloc_space   = 0;
@@ skipping 37 matching lines @@
              "functions!"     => \$main::opt_functions,
              "lines!"         => \$main::opt_lines,
              "addresses!"     => \$main::opt_addresses,
              "files!"         => \$main::opt_files,
              "text!"          => \$main::opt_text,
              "callgrind!"     => \$main::opt_callgrind,
              "list=s"         => \$main::opt_list,
              "disasm=s"       => \$main::opt_disasm,
              "symbols!"       => \$main::opt_symbols,
              "gv!"            => \$main::opt_gv,
+             "evince!"        => \$main::opt_evince,
              "web!"           => \$main::opt_web,
              "dot!"           => \$main::opt_dot,
              "ps!"            => \$main::opt_ps,
              "pdf!"           => \$main::opt_pdf,
              "svg!"           => \$main::opt_svg,
              "gif!"           => \$main::opt_gif,
              "raw!"           => \$main::opt_raw,
              "interactive!"   => \$main::opt_interactive,
              "nodecount=i"    => \$main::opt_nodecount,
              "nodefraction=f" => \$main::opt_nodefraction,
              "edgefraction=f" => \$main::opt_edgefraction,
+             "maxdegree=i"    => \$main::opt_maxdegree,
              "focus=s"        => \$main::opt_focus,
              "ignore=s"       => \$main::opt_ignore,
              "scale=i"        => \$main::opt_scale,
              "heapcheck"      => \$main::opt_heapcheck,
              "inuse_space!"   => \$main::opt_inuse_space,
              "inuse_objects!" => \$main::opt_inuse_objects,
              "alloc_space!"   => \$main::opt_alloc_space,
              "alloc_objects!" => \$main::opt_alloc_objects,
              "show_bytes!"    => \$main::opt_show_bytes,
              "drop_negative!" => \$main::opt_drop_negative,
@@ skipping 49 matching lines @@
   }
 
   # Check output modes
   my $modes =
       $main::opt_text +
       $main::opt_callgrind +
       ($main::opt_list eq '' ? 0 : 1) +
       ($main::opt_disasm eq '' ? 0 : 1) +
       ($main::opt_symbols == 0 ? 0 : 1) +
       $main::opt_gv +
+      $main::opt_evince +
       $main::opt_web +
       $main::opt_dot +
       $main::opt_ps +
       $main::opt_pdf +
       $main::opt_svg +
       $main::opt_gif +
       $main::opt_raw +
       $main::opt_interactive +
       0;
   if ($modes > 1) {
@@ skipping 122 matching lines @@
   # Get total data in profile
   my $total = TotalProfile($profile);
 
   # Collect symbols
   my $symbols;
   if ($main::use_symbolized_profile) {
     $symbols = FetchSymbols($pcs, $symbol_map);
   } elsif ($main::use_symbol_page) {
     $symbols = FetchSymbols($pcs);
   } else {
+    # TODO(csilvers): $libs uses the /proc/self/maps data from profile1,
+    # which may differ from the data from subsequent profiles, especially
+    # if they were run on different machines.  Use appropriate libs for
+    # each pc somehow.
     $symbols = ExtractSymbols($libs, $pcs);
   }
 
   # Remove uniniteresting stack items
   $profile = RemoveUninterestingFrames($symbols, $profile);
 
   # Focus?
   if ($main::opt_focus ne '') {
     $profile = FocusProfile($symbols, $profile, $main::opt_focus);
   }
 
   # Ignore?
   if ($main::opt_ignore ne '') {
     $profile = IgnoreProfile($symbols, $profile, $main::opt_ignore);
   }
 
   my $calls = ExtractCalls($symbols, $profile);
 
   # Reduce profiles to required output granularity, and also clean
   # each stack trace so a given entry exists at most once.
   my $reduced = ReduceProfile($symbols, $profile);
 
   # Get derived profiles
   my $flat = FlatProfile($reduced);
   my $cumulative = CumulativeProfile($reduced);
 
   # Print
   if (!$main::opt_interactive) {
     if ($main::opt_disasm) {
-      PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm, $total);
+      PrintDisassembly($libs, $flat, $cumulative, $main::opt_disasm);
     } elsif ($main::opt_list) {
       PrintListing($libs, $flat, $cumulative, $main::opt_list);
     } elsif ($main::opt_text) {
       # Make sure the output is empty when have nothing to report
       # (only matters when --heapcheck is given but we must be
       # compatible with old branches that did not pass --heapcheck always):
       if ($total != 0) {
         printf("Total: %s %s\n", Unparse($total), Units());
       }
-      PrintText($symbols, $flat, $cumulative, $total, -1);
+      PrintText($symbols, $flat, $cumulative, -1);
     } elsif ($main::opt_raw) {
       PrintSymbolizedProfile($symbols, $profile, $main::prog);
     } elsif ($main::opt_callgrind) {
       PrintCallgrind($calls);
     } else {
       if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
         if ($main::opt_gv) {
           RunGV(TempName($main::next_tmpfile, "ps"), "");
+        } elsif ($main::opt_evince) {
+          RunEvince(TempName($main::next_tmpfile, "pdf"), "");
         } elsif ($main::opt_web) {
           my $tmp = TempName($main::next_tmpfile, "svg");
           RunWeb($tmp);
           # The command we run might hand the file name off
           # to an already running browser instance and then exit.
           # Normally, we'd remove $tmp on exit (right now),
           # but fork a child to remove $tmp a little later, so that the
           # browser has time to load it first.
           delete $main::tempnames{$tmp};
           if (fork() == 0) {
@@ skipping 28 matching lines @@
   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")) {
+  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);
   }
 }
 
+sub RunEvince {
+  my $fname = shift;
+  my $bg = shift;       # "" or " &" if we should run in background
+  system("$EVINCE " . $fname . $bg);
+}
+
 sub RunWeb {
   my $fname = shift;
   print STDERR "Loading web page file:///$fname\n";
 
   if (`uname` =~ /Darwin/) {
     # OS X: open will use standard preference for SVG files.
     system("/usr/bin/open", $fname);
     return;
   }
 
   # Some kind of Unix; try generic symlinks, then specific browsers.
   # (Stop once we find one.)
   # Works best if the browser is already running.
   my @alt = (
     "/etc/alternatives/gnome-www-browser",
     "/etc/alternatives/x-www-browser",
     "google-chrome",
     "firefox",
   );
   foreach my $b (@alt) {
-    if (-f $b) {
-      if (system($b, $fname) == 0) {
-        return;
-      }
+    if (system($b, $fname) == 0) {
+      return;
     }
   }
 
   print STDERR "Could not load web browser.\n";
 }
 
 sub RunKcachegrind {
   my $fname = shift;
   my $bg = shift;       # "" or " &" if we should run in background
   print STDERR "Starting '$KCACHEGRIND " . $fname . $bg . "'\n";
@@ skipping 55 matching lines @@
   if (m/^\s*help/) {
     InteractiveHelpMessage();
     return 1;
   }
   # Clear all the mode options -- mode is controlled by "$command"
   $main::opt_text = 0;
   $main::opt_callgrind = 0;
   $main::opt_disasm = 0;
   $main::opt_list = 0;
   $main::opt_gv = 0;
+  $main::opt_evince = 0;
   $main::opt_cum = 0;
 
   if (m/^\s*(text|top)(\d*)\s*(.*)/) {
     $main::opt_text = 1;
 
     my $line_limit = ($2 ne "") ? int($2) : 10;
 
     my $routine;
     my $ignore;
     ($routine, $ignore) = ParseInteractiveArgs($3);
 
     my $profile = ProcessProfile($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);
+    PrintText($symbols, $flat, $cumulative, $line_limit);
     return 1;
   }
   if (m/^\s*callgrind\s*([^ \n]*)/) {
     $main::opt_callgrind = 1;
 
     # Get derived profiles
     my $calls = ExtractCalls($symbols, $orig_profile);
     my $filename = $1;
     if ( $1 eq '' ) {
       $filename = TempName($main::next_tmpfile, "callgrind");
@@ skipping 31 matching lines @@
     ($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, $total);
+    PrintDisassembly($libs, $flat, $cumulative, $routine);
     return 1;
   }
-  if (m/^\s*(gv|web)\s*(.*)/) {
+  if (m/^\s*(gv|web|evince)\s*(.*)/) {
     $main::opt_gv = 0;
+    $main::opt_evince = 0;
     $main::opt_web = 0;
     if ($1 eq "gv") {
       $main::opt_gv = 1;
+    } elsif ($1 eq "evince") {
+      $main::opt_evince = 1;
     } elsif ($1 eq "web") {
       $main::opt_web = 1;
     }
 
     my $focus;
     my $ignore;
     ($focus, $ignore) = ParseInteractiveArgs($2);
 
     # Process current profile to account for various settings
     my $profile = ProcessProfile($orig_profile, $symbols, $focus, $ignore);
     my $reduced = ReduceProfile($symbols, $profile);
 
     # Get derived profiles
     my $flat = FlatProfile($reduced);
     my $cumulative = CumulativeProfile($reduced);
 
     if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
       if ($main::opt_gv) {
         RunGV(TempName($main::next_tmpfile, "ps"), " &");
+      } elsif ($main::opt_evince) {
+        RunEvince(TempName($main::next_tmpfile, "pdf"), " &");
       } elsif ($main::opt_web) {
         RunWeb(TempName($main::next_tmpfile, "svg"));
       }
       $main::next_tmpfile++;
     }
     return 1;
   }
   if (m/^\s*$/) {
     return 1;
   }
@@ skipping 192 matching lines @@
     # dump a cpu-format profile to standard out
     PrintProfileData($profile);
   }
 }
 
 # Print text output
 sub PrintText {
   my $symbols = shift;
   my $flat = shift;
   my $cumulative = shift;
-  my $total = shift;
   my $line_limit = shift;
 
+  my $total = TotalProfile($flat);
+
   # Which profile to sort by?
   my $s = $main::opt_cum ? $cumulative : $flat;
 
   my $running_sum = 0;
   my $lines = 0;
   foreach my $k (sort { GetEntry($s, $b) <=> GetEntry($s, $a) || $a cmp $b }
                  keys(%{$cumulative})) {
     my $f = GetEntry($flat, $k);
     my $c = GetEntry($cumulative, $k);
     $running_sum += $f;
@@ skipping 54 matching lines @@
     printf CG ("$caller_line $count\n\n");
   }
 }
 
 # Print disassembly for all all routines that match $main::opt_disasm
 sub PrintDisassembly {
   my $libs = shift;
   my $flat = shift;
   my $cumulative = shift;
   my $disasm_opts = shift;
-  my $total = shift;
+
+  my $total = TotalProfile($flat);
 
   foreach my $lib (@{$libs}) {
     my $symbol_table = GetProcedureBoundaries($lib->[0], $disasm_opts);
     my $offset = AddressSub($lib->[1], $lib->[3]);
     foreach my $routine (sort ByName keys(%{$symbol_table})) {
       my $start_addr = $symbol_table->{$routine}->[0];
       my $end_addr = $symbol_table->{$routine}->[1];
       # See if there are any samples in this routine
       my $length = hex(AddressSub($end_addr, $start_addr));
       my $addr = AddressAdd($start_addr, $offset);
@@ skipping 473 matching lines @@
   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 -Tps2 >" . TempName($main::next_tmpfile, "ps");
+  } elsif ($main::opt_evince) {
+    $output = "| $DOT -Tps2 | $PS2PDF - " . TempName($main::next_tmpfile, "pdf");
   } elsif ($main::opt_ps) {
     $output = "| $DOT -Tps2";
   } elsif ($main::opt_pdf) {
     $output = "| $DOT -Tps2 | $PS2PDF - -";
   } elsif ($main::opt_web || $main::opt_svg) {
     # We need to post-process the SVG, so write to a temporary file always.
     $output = "| $DOT -Tsvg >" . TempName($main::next_tmpfile, "svg");
   } elsif ($main::opt_gif) {
     $output = "| $DOT -Tgif";
   } else {
@@ skipping 40 matching lines @@
     $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));
+                       Percent($c, $local_total));
     }
     my $style = "";
     if ($main::opt_heapcheck) {
       if ($f > 0) {
         # make leak-causing nodes more visible (add a background)
         $style = ",style=filled,fillcolor=gray"
       } elsif ($f < 0) {
         # make anti-leak-causing nodes (which almost never occur)
         # stand out as well (triple border)
         $style = ",peripheries=3"
       }
     }
 
     printf DOT ("N%d [label=\"%s\\n%s (%s)%s\\r" .
                 "\",shape=box,fontsize=%.1f%s];\n",
                 $node{$a},
                 $sym,
                 Unparse($f),
-                Percent($f, $overall_total),
+                Percent($f, $local_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 @translated = TranslateStack($symbols, $k);
     for (my $i = 1; $i <= $#translated; $i++) {
       my $src = $translated[$i];
       my $dst = $translated[$i-1];
       #next if ($src eq $dst);  # Avoid self-edges?
       if (exists($node{$src}) && exists($node{$dst})) {
         my $edge_label = "$src\001$dst";
         if (!exists($edge{$edge_label})) {
           $edge{$edge_label} = 0;
         }
         $edge{$edge_label} += $n;
       }
     }
   }
 
-  # Print edges
-  foreach my $e (keys(%edge)) {
+  # Print edges (process in order of decreasing counts)
+  my %indegree = ();   # Number of incoming edges added per node so far
+  my %outdegree = ();  # Number of outgoing edges added per node so far
+  foreach my $e (sort { $edge{$b} <=> $edge{$a} } keys(%edge)) {
     my @x = split(/\001/, $e);
     $n = $edge{$e};
 
-    if (abs($n) > $edgelimit) {
+    # Initialize degree of kept incoming and outgoing edges if necessary
+    my $src = $x[0];
+    my $dst = $x[1];
+    if (!exists($outdegree{$src})) { $outdegree{$src} = 0; }
+    if (!exists($indegree{$dst})) { $indegree{$dst} = 0; }
+
+    my $keep;
+    if ($indegree{$dst} == 0) {
+      # Keep edge if needed for reachability
+      $keep = 1;
+    } elsif (abs($n) <= $edgelimit) {
+      # Drop if we are below --edgefraction
+      $keep = 0;
+    } elsif ($outdegree{$src} >= $main::opt_maxdegree ||
+             $indegree{$dst} >= $main::opt_maxdegree) {
+      # Keep limited number of in/out edges per node
+      $keep = 0;
+    } else {
+      $keep = 1;
+    }
+
+    if ($keep) {
+      $outdegree{$src}++;
+      $indegree{$dst}++;
+
       # Compute line width based on edge count
       my $fraction = abs($local_total ? (3 * ($n / $local_total)) : 0);
       if ($fraction > 1) { $fraction = 1; }
       my $w = $fraction * 2;
       if ($w < 1 && ($main::opt_web || $main::opt_svg)) {
         # SVG output treats line widths < 1 poorly.
         $w = 1;
       }
 
       # Dot sometimes segfaults if given edge weights that are too large, so
@@ skipping 317 matching lines @@
         if(state == 'pan' || state == 'move') {
                 // Quit pan mode
                 state = '';
         }
 }
 
 ]]></script>
 EOF
 }
 
+# Return a small number that identifies the argument.
+# Multiple calls with the same argument will return the same number.
+# Calls with different arguments will return different numbers.
+sub ShortIdFor {
+  my $key = shift;
+  my $id = $main::uniqueid{$key};
+  if (!defined($id)) {
+    $id = keys(%main::uniqueid) + 1;
+    $main::uniqueid{$key} = $id;
+  }
+  return $id;
+}
+
 # Translate a stack of addresses into a stack of symbols
 sub TranslateStack {
   my $symbols = shift;
   my $k = shift;
 
   my @addrs = split(/\n/, $k);
   my @result = ();
   for (my $i = 0; $i <= $#addrs; $i++) {
     my $a = $addrs[$i];
 
@@ skipping 17 matching lines @@
     # (more than one symbol in the case of inlining).  Callers
     # come before callees in symlist, so walk backwards since
     # the translated stack should contain callees before callers.
     for (my $j = $#{$symlist}; $j >= 2; $j -= 3) {
       my $func = $symlist->[$j-2];
       my $fileline = $symlist->[$j-1];
       my $fullfunc = $symlist->[$j];
       if ($j > 2) {
         $func = "$func (inline)";
       }
+
+      # Do not merge nodes corresponding to Callback::Run since that
+      # causes confusing cycles in dot display.  Instead, we synthesize
+      # a unique name for this frame per caller.
+      if ($func =~ m/Callback.*::Run$/) {
+        my $caller = ($i > 0) ? $addrs[$i-1] : 0;
+        $func = "Run#" . ShortIdFor($caller);
+      }
+
       if ($main::opt_addresses) {
         push(@result, "$a $func $fileline");
       } elsif ($main::opt_lines) {
         if ($func eq '??' && $fileline eq '??:0') {
           push(@result, "$a");
         } else {
           push(@result, "$func $fileline");
         }
       } elsif ($main::opt_functions) {
         if ($func eq '??') {
@@ skipping 223 matching lines @@
                       '__start_malloc_hook',
                       '__stop_malloc_hook') {
       $skip{$name} = 1;
       $skip{"_" . $name} = 1;   # Mach (OS X) adds a _ prefix to everything
     }
     # TODO: Remove TCMalloc once everything has been
     # moved into the tcmalloc:: namespace and we have flushed
     # old code out of the system.
     $skip_regexp = "TCMalloc|^tcmalloc::";
   } elsif ($main::profile_type eq 'contention') {
-    foreach my $vname ('Mutex::Unlock', 'Mutex::UnlockSlow') {
+    foreach my $vname ('base::RecordLockProfileData',
+                       'base::SubmitMutexProfileData',
+                       'base::SubmitSpinLockProfileData',
+                       'Mutex::Unlock',
+                       'Mutex::UnlockSlow',
+                       'Mutex::ReaderUnlock',
+                       'MutexLock::~MutexLock',
+                       'SpinLock::Unlock',
+                       'SpinLock::SlowUnlock',
+                       'SpinLockHolder::~SpinLockHolder') {
       $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',
                       '__FRAME_END__',
@@ skipping 276 matching lines @@
     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, $prefix, $path) = ParseProfileURL($profile_name);
-  return defined($host) and defined($port) and defined($path);
+  if (-f $profile_name) {
+    printf STDERR "Using local file $profile_name.\n";
+    return 0;
+  }
+  return 1;
 }
 
 sub ParseProfileURL {
   my $profile_name = shift;
-  if (defined($profile_name) &&
-      $profile_name =~ m,^(http://|)([^/:]+):(\d+)(|\@\d+)(|/|(.*?)($PROFILE_PAGE|$PMUPROFILE_PAGE|$HEAP_PAGE|$GROWTH_PAGE|$CONTENTION_PAGE|$WALL_PAGE|$FILTEREDPROFILE_PAGE))$,o) {
-    # $7 is $PROFILE_PAGE/$HEAP_PAGE/etc.  $5 is *everything* after
-    # the hostname, as long as that everything is the empty string,
-    # a slash, or something ending in $PROFILE_PAGE/$HEAP_PAGE/etc.
-    # So "$7 || $5" is $PROFILE_PAGE/etc if there, or else it's "/" or "".
-    return ($2, $3, $6, $7 || $5);
+
+  if (!defined($profile_name) || $profile_name eq "") {
+    return ();
   }
-  return ();
+
+  # Split profile URL - matches all non-empty strings, so no test.
+  $profile_name =~ m,^(https?://)?([^/]+)(.*?)(/|$PROFILES)?$,;
+
+  my $proto = $1 || "http://";
+  my $hostport = $2;
+  my $prefix = $3;
+  my $profile = $4 || "/";
+
+  my $host = $hostport;
+  $host =~ s/:.*//;
+
+  my $baseurl = "$proto$hostport$prefix";
+  return ($host, $baseurl, $profile);
 }
 
 # We fetch symbols from the first profile argument.
 sub SymbolPageURL {
-  my ($host, $port, $prefix, $path) = ParseProfileURL($main::pfile_args[0]);
-  return "http://$host:$port$prefix$SYMBOL_PAGE";
+  my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);
+  return "$baseURL$SYMBOL_PAGE";
 }
 
 sub FetchProgramName() {
-  my ($host, $port, $prefix, $path) = ParseProfileURL($main::pfile_args[0]);
-  my $url = "http://$host:$port$prefix$PROGRAM_NAME_PAGE";
+  my ($host, $baseURL, $path) = ParseProfileURL($main::pfile_args[0]);
+  my $url = "$baseURL$PROGRAM_NAME_PAGE";
   my $command_line = "$URL_FETCHER '$url'";
   open(CMDLINE, "$command_line |") or error($command_line);
   my $cmdline = <CMDLINE>;
   $cmdline =~ s/\r//g;   # turn windows-looking lines into unix-looking lines
   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;
 }
@@ skipping 130 matching lines @@
 }
 
 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, $prefix, $path) = ParseProfileURL($profile_name);
+  my ($host, $baseURL, $path) = ParseProfileURL($profile_name);
   my $binary_shortname = BaseName($binary_name);
-  return sprintf("%s.%s.%s-port%s",
-                 $binary_shortname, $main::op_time, $host, $port);
+  return sprintf("%s.%s.%s",
+                 $binary_shortname, $main::op_time, $host);
 }
 
 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, $prefix, $path) = ParseProfileURL($profile_name);
+    my ($host, $baseURL, $path) = ParseProfileURL($profile_name);
     if ($path eq "" || $path eq "/") {
       # Missing type specifier defaults to cpu-profile
       $path = $PROFILE_PAGE;
     }
 
     my $profile_file = MakeProfileBaseName($binary_name, $profile_name);
 
-    my $url;
+    my $url = "$baseURL$path";
     my $fetch_timeout = undef;
-    if (($path =~ m/$PROFILE_PAGE/) || ($path =~ m/$PMUPROFILE_PAGE/)) {
-      if ($path =~ m/$PROFILE_PAGE/) {
-        $url = sprintf("http://$host:$port$prefix$path?seconds=%d",
-            $main::opt_seconds);
+    if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE/) {
+      if ($path =~ m/[?]/) {
+        $url .= "&";
       } else {
-        if ($profile_name =~ m/[?]/) {
-          $profile_name .= "&"
-        } else {
-          $profile_name .= "?"
-        }
-        $url = sprintf("http://$profile_name" . "seconds=%d",
-            $main::opt_seconds);
+        $url .= "?";
       }
+      $url .= sprintf("seconds=%d", $main::opt_seconds);
       $fetch_timeout = $main::opt_seconds * 1.01 + 60;
     } else {
       # For non-CPU profiles, we add a type-extension to
       # the target profile file name.
       my $suffix = $path;
       $suffix =~ s,/,.,g;
-      $profile_file .= "$suffix";
-      $url = "http://$host:$port$prefix$path";
+      $profile_file .= $suffix;
     }
 
     my $profile_dir = $ENV{"PPROF_TMPDIR"} || ($ENV{HOME} . "/pprof");
-    if (!(-d $profile_dir)) {
+    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 $fetcher = AddFetchTimeout($URL_FETCHER, $fetch_timeout);
     my $cmd = "$fetcher '$url' > '$tmp_profile'";
-    if (($path =~ m/$PROFILE_PAGE/) || ($path =~ m/$PMUPROFILE_PAGE/)){
+    if ($path =~ m/$PROFILE_PAGE|$PMUPROFILE_PAGE|$CENSUSPROFILE_PAGE/){
       print STDERR "Gathering CPU profile from $url for $main::opt_seconds seconds to\n  ${real_profile}\n";
       if ($encourage_patience) {
         print STDERR "Be patient...\n";
       }
     } else {
-      print STDERR "Fetching $path profile from $host:$port to\n  ${real_profile}\n";
+      print STDERR "Fetching $path profile from $url 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;
   }
 }
 
@@ skipping 65 matching lines @@
 BEGIN {
   package CpuProfileStream;
 
   sub new {
     my ($class, $file, $fname) = @_;
     my $self = { file        => $file,
                  base        => 0,
                  stride      => 512 * 1024,   # must be a multiple of bitsize/8
                  slots       => [],
                  unpack_code => "",           # N for big-endian, V for little
+                 perl_is_64bit => 1,          # matters if profile is 64-bit
     };
     bless $self, $class;
     # Let unittests adjust the stride
     if ($main::opt_test_stride > 0) {
       $self->{stride} = $main::opt_test_stride;
     }
     # Read the first two slots to figure out bitsize and endianness.
     my $slots = $self->{slots};
     my $str;
     read($self->{file}, $str, 8);
     # Set the global $address_length based on what we see here.
     # 8 is 32-bit (8 hexadecimal chars); 16 is 64-bit (16 hexadecimal chars).
     $address_length = ($str eq (chr(0)x8)) ? 16 : 8;
     if ($address_length == 8) {
       if (substr($str, 6, 2) eq chr(0)x2) {
         $self->{unpack_code} = 'V';  # Little-endian.
       } elsif (substr($str, 4, 2) eq chr(0)x2) {
         $self->{unpack_code} = 'N';  # Big-endian
       } else {
         ::error("$fname: header size >= 2**16\n");
       }
       @$slots = unpack($self->{unpack_code} . "*", $str);
     } else {
-      # If we're a 64-bit profile, make sure we're a 64-bit-capable
+      # If we're a 64-bit profile, check if we're a 64-bit-capable
       # perl.  Otherwise, each slot will be represented as a float
       # instead of an int64, losing precision and making all the
-      # 64-bit addresses right.  We *could* try to handle this with
-      # software emulation of 64-bit ints, but that's added complexity
-      # for no clear benefit (yet).  We use 'Q' to test for 64-bit-ness;
-      # perl docs say it's only available on 64-bit perl systems.
+      # 64-bit addresses wrong.  We won't complain yet, but will
+      # later if we ever see a value that doesn't fit in 32 bits.
       my $has_q = 0;
       eval { $has_q = pack("Q", "1") ? 1 : 1; };
       if (!$has_q) {
-        ::error("$fname: need a 64-bit perl to process this 64-bit profile.\n");
+        $self->{perl_is_64bit} = 0;
       }
       read($self->{file}, $str, 8);
       if (substr($str, 4, 4) eq chr(0)x4) {
         # We'd love to use 'Q', but it's a) not universal, b) not endian-proof.
         $self->{unpack_code} = 'V';  # Little-endian.
       } elsif (substr($str, 0, 4) eq chr(0)x4) {
         $self->{unpack_code} = 'N';  # Big-endian
       } else {
         ::error("$fname: header size >= 2**32\n");
       }
@@ skipping 15 matching lines @@
       # This is the easy case: unpack provides 32-bit unpacking primitives.
       @$slots = unpack($self->{unpack_code} . "*", $str);
     } else {
       # We need to unpack 32 bits at a time and combine.
       my @b32_values = unpack($self->{unpack_code} . "*", $str);
       my @b64_values = ();
       for (my $i = 0; $i < $#b32_values; $i += 2) {
         # TODO(csilvers): if this is a 32-bit perl, the math below
         #    could end up in a too-large int, which perl will promote
         #    to a double, losing necessary precision.  Deal with that.
-        if ($self->{unpack_code} eq 'V') {    # little-endian
-          push(@b64_values, $b32_values[$i] + $b32_values[$i+1] * (2**32));
-        } else {
-          push(@b64_values, $b32_values[$i] * (2**32) + $b32_values[$i+1]);
-        }
+        #    Right now, we just die.
+        my ($lo, $hi) = ($b32_values[$i], $b32_values[$i+1]);
+        if ($self->{unpack_code} eq 'N') {    # big-endian
+          ($lo, $hi) = ($hi, $lo);
+        }
+        my $value = $lo + $hi * (2**32);
+        if (!$self->{perl_is_64bit} &&   # check value is exactly represented
+            (($value % (2**32)) != $lo || int($value / (2**32)) != $hi)) {
+          ::error("Need a 64-bit perl to process this 64-bit profile.\n");
+        }
+        push(@b64_values, $value);
       }
       @$slots = @b64_values;
     }
   }
 
   # Access the i-th long in the file (logically), or -1 at EOF.
   sub get {
     my ($self, $idx) = @_;
     my $slots = $self->{slots};
     while ($#$slots >= 0) {
       if ($idx < $self->{base}) {
         # The only time we expect a reference to $slots[$i - something]
         # after referencing $slots[$i] is reading the very first header.
         # Since $stride > |header|, that shouldn't cause any lookback
         # errors.  And everything after the header is sequential.
         print STDERR "Unexpected look-back reading CPU profile";
         return -1;   # shrug, don't know what better to return
       } elsif ($idx > $self->{base} + $#$slots) {
         $self->overflow();
       } else {
         return $slots->[$idx - $self->{base}];
       }
     }
     # If we get here, $slots is [], which means we've reached EOF
     return -1;  # unique since slots is supposed to hold unsigned numbers
   }
 }
 
-# Return the next line from the profile file, assuming it's a text
-# line (which in this case means, doesn't start with a NUL byte).  If
-# it's not a text line, return "".  At EOF, return undef, like perl does.
-# Input file should be in binmode.
-sub ReadProfileLine {
+# Reads the top, 'header' section of a profile, and returns the last
+# line of the header, commonly called a 'header line'.  The header
+# section of a profile consists of zero or more 'command' lines that
+# are instructions to pprof, which pprof executes when reading the
+# header.  All 'command' lines start with a %.  After the command
+# lines is the 'header line', which is a profile-specific line that
+# indicates what type of profile it is, and perhaps other global
+# information about the profile.  For instance, here's a header line
+# for a heap profile:
+#   heap profile:     53:    38236 [  5525:  1284029] @ heapprofile
+# For historical reasons, the CPU profile does not contain a text-
+# readable header line.  If the profile looks like a CPU profile,
+# this function returns "".  If no header line could be found, this
+# function returns undef.
+#
+# The following commands are recognized:
+#   %warn -- emit the rest of this line to stderr, prefixed by 'WARNING:'
+#
+# The input file should be in binmode.
+sub ReadProfileHeader {
   local *PROFILE = shift;
   my $firstchar = "";
   my $line = "";
   read(PROFILE, $firstchar, 1);
-  seek(PROFILE, -1, 1);          # unread the firstchar
-  if ($firstchar eq "\0") {
+  seek(PROFILE, -1, 1);                    # unread the firstchar
+  if ($firstchar !~ /[[:print:]]/) {       # is not a text character
     return "";
   }
-  $line = <PROFILE>;
-  if (defined($line)) {
+  while (defined($line = <PROFILE>)) {
     $line =~ s/\r//g;   # turn windows-looking lines into unix-looking lines
+    if ($line =~ /^%warn\s+(.*)/) {        # 'warn' command
+      # Note this matches both '%warn blah\n' and '%warn\n'.
+      print STDERR "WARNING: $1\n";        # print the rest of the line
+    } elsif ($line =~ /^%/) {
+      print STDERR "Ignoring unknown command from profile header: $line";
+    } else {
+      # End of commands, must be the header line.
+      return $line;
+    }
   }
-  return $line;
+  return undef;     # got to EOF without seeing a header line
 }
 
 sub IsSymbolizedProfileFile {
   my $file_name = shift;
   if (!(-e $file_name) || !(-r $file_name)) {
     return 0;
   }
   # Check if the file contains a symbol-section marker.
   open(TFILE, "<$file_name");
   binmode TFILE;
-  my $firstline = ReadProfileLine(*TFILE);
+  my $firstline = ReadProfileHeader(*TFILE);
   close(TFILE);
   if (!$firstline) {
     return 0;
   }
   $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
   my $symbol_marker = $&;
   return $firstline =~ /^--- *$symbol_marker/;
 }
 
 # 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;
-
-  if (IsSymbolizedProfileFile($fname) && !$main::use_symbolized_profile) {
-    # we have both a binary and symbolized profiles, abort
-    usage("Symbolized profile '$fname' cannot be used with a binary arg.  " .
-          "Try again without passing '$prog'.");
-  }
-
-  $main::profile_type = '';
+  my $result;            # return value
 
   $CONTENTION_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
   my $contention_marker = $&;
   $GROWTH_PAGE  =~ m,[^/]+$,;    # matches everything after the last slash
   my $growth_marker = $&;
   $SYMBOL_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
   my $symbol_marker = $&;
   $PROFILE_PAGE =~ m,[^/]+$,;    # matches everything after the last slash
   my $profile_marker = $&;
 
   # Look at first line to see if it is a heap or a CPU profile.
   # CPU profile may start with no header at all, and just binary data
   # (starting with \0\0\0\0) -- in that case, don't try to read the
   # whole firstline, since it may be gigabytes(!) of data.
   open(PROFILE, "<$fname") || error("$fname: $!\n");
   binmode PROFILE;      # New perls do UTF-8 processing
-  my $header = ReadProfileLine(*PROFILE);
+  my $header = ReadProfileHeader(*PROFILE);
   if (!defined($header)) {   # means "at EOF"
     error("Profile is empty.\n");
   }
 
   my $symbols;
   if ($header =~ m/^--- *$symbol_marker/o) {
+    # Verify that the user asked for a symbolized profile
+    if (!$main::use_symbolized_profile) {
+      # we have both a binary and symbolized profiles, abort
+      error("FATAL ERROR: Symbolized profile\n   $fname\ncannot be used with " .
+            "a binary arg. Try again without passing\n   $prog\n");
+    }
     # Read the symbol section of the symbolized profile file.
     $symbols = ReadSymbols(*PROFILE{IO});
     # Read the next line to get the header for the remaining profile.
-    $header = ReadProfileLine(*PROFILE) || "";
+    $header = ReadProfileHeader(*PROFILE) || "";
   }
 
-  my $result;
-
+  $main::profile_type = '';
   if ($header =~ m/^heap profile:.*$growth_marker/o) {
     $main::profile_type = 'growth';
-    $result =  ReadHeapProfile($prog, $fname, $header);
+    $result =  ReadHeapProfile($prog, *PROFILE, $header);
   } elsif ($header =~ m/^heap profile:/) {
     $main::profile_type = 'heap';
-    $result =  ReadHeapProfile($prog, $fname, $header);
+    $result =  ReadHeapProfile($prog, *PROFILE, $header);
   } elsif ($header =~ m/^--- *$contention_marker/o) {
     $main::profile_type = 'contention';
-    $result = ReadSynchProfile($prog, $fname);
+    $result = ReadSynchProfile($prog, *PROFILE);
   } elsif ($header =~ m/^--- *Stacks:/) {
     print STDERR
       "Old format contention profile: mistakenly reports " .
       "condition variable signals as lock contentions.\n";
     $main::profile_type = 'contention';
-    $result = ReadSynchProfile($prog, $fname);
+    $result = ReadSynchProfile($prog, *PROFILE);
   } elsif ($header =~ m/^--- *$profile_marker/) {
     # the binary cpu profile data starts immediately after this line
     $main::profile_type = 'cpu';
-    $result = ReadCPUProfile($prog, $fname);
+    $result = ReadCPUProfile($prog, $fname, *PROFILE);
   } else {
     if (defined($symbols)) {
       # a symbolized profile contains a format we don't recognize, bail out
       error("$fname: Cannot recognize profile section after symbols.\n");
     }
     # no ascii header present -- must be a CPU profile
     $main::profile_type = 'cpu';
-    $result = ReadCPUProfile($prog, $fname);
+    $result = ReadCPUProfile($prog, $fname, *PROFILE);
   }
 
+  close(PROFILE);
+
   # if we got symbols along with the profile, return those as well
   if (defined($symbols)) {
     $result->{symbols} = $symbols;
   }
 
   return $result;
 }
 
 # Subtract one from caller pc so we map back to call instr.
 # However, don't do this if we're reading a symbolized profile
@@ skipping 18 matching lines @@
     for (my $i = 1; $i <= $#addrs; $i++) {
       $fixedaddrs[$i] = AddressSub($addrs[$i], "0x1");
     }
     return join $delimiter, @fixedaddrs;
   }
 }
 
 # CPU profile reader
 sub ReadCPUProfile {
   my $prog = shift;
-  my $fname = shift;
+  my $fname = shift;       # just used for logging
+  local *PROFILE = shift;
   my $version;
   my $period;
   my $i;
   my $profile = {};
   my $pcs = {};
 
   # Parse string into array of slots.
   my $slots = CpuProfileStream->new(*PROFILE, $fname);
 
   # Read header.  The current header version is a 5-element structure
@@ skipping 46 matching lines @@
     }
 
     AddEntry($profile, (join "\n", @k), $n);
     $i += $d;
   }
 
   # Parse map
   my $map = '';
   seek(PROFILE, $i * 4, 0);
   read(PROFILE, $map, (stat PROFILE)[7]);
-  close(PROFILE);
 
   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;
+  local *PROFILE = 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) {
@@ skipping 121 matching lines @@
     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) {
         if ($sampling_algorithm == 2) {
           # Remote-heap version 2
           # The sampling frequency is the rate of a Poisson process.
           # This means that the probability of sampling an allocation of
           # size X with sampling rate Y is 1 - exp(-X/Y)
-          my $ratio;
-          $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
-          my $scale_factor;
-          $scale_factor = 1/(1 - exp(-$ratio));
-          $n1 *= $scale_factor;
-          $s1 *= $scale_factor;
-          $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
-          $scale_factor = 1/(1 - exp(-$ratio));
-          $n2 *= $scale_factor;
-          $s2 *= $scale_factor;
+          if ($n1 != 0) {
+            my $ratio = (($s1*1.0)/$n1)/($sample_adjustment);
+            my $scale_factor = 1/(1 - exp(-$ratio));
+            $n1 *= $scale_factor;
+            $s1 *= $scale_factor;
+          }
+          if ($n2 != 0) {
+            my $ratio = (($s2*1.0)/$n2)/($sample_adjustment);
+            my $scale_factor = 1/(1 - exp(-$ratio));
+            $n2 *= $scale_factor;
+            $s2 *= $scale_factor;
+          }
         } else {
           # Remote-heap version 1
           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) {
@@ skipping 11 matching lines @@
   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 $prog = shift;
+  local *PROFILE = shift;
+  my $header = shift;
 
   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;
@@ skipping 54 matching lines @@
         # So we just silently ignore it for now
       } else {
         printf STDERR ("Ignoring unnknown variable in /contention 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;
@@ skipping 423 matching lines @@
   }
 }
 
 # Extract symbols for all PC values found in profile
 sub ExtractSymbols {
   my $libs = shift;
   my $pcset = shift;
 
   my $symbols = {};
 
-  # Map each PC value to the containing library
-  my %seen = ();
-  foreach my $lib (@{$libs}) {
+  # Map each PC value to the containing library.  To make this faster,
+  # we sort libraries by their starting pc value (highest first), and
+  # advance through the libraries as we advance the pc.  Sometimes the
+  # addresses of libraries may overlap with the addresses of the main
+  # binary, so to make sure the libraries 'win', we iterate over the
+  # libraries in reverse order (which assumes the binary doesn't start
+  # in the middle of a library, which seems a fair assumption).
+  my @pcs = (sort { $a cmp $b } keys(%{$pcset}));  # pcset is 0-extended strings
+  foreach my $lib (sort {$b->[1] cmp $a->[1]} @{$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);
-      }
+    my ($start_pc_index, $finish_pc_index);
+    # Find smallest finish_pc_index such that $finish < $pc[$finish_pc_index].
+    for ($finish_pc_index = $#pcs + 1; $finish_pc_index > 0;
+         $finish_pc_index--) {
+      last if $pcs[$finish_pc_index - 1] le $finish;
     }
+    # Find smallest start_pc_index such that $start <= $pc[$start_pc_index].
+    for ($start_pc_index = $finish_pc_index; $start_pc_index > 0;
+         $start_pc_index--) {
+      last if $pcs[$start_pc_index - 1] lt $start;
+    }
+    # This keeps PC values higher than $pc[$finish_pc_index] in @pcs,
+    # in case there are overlaps in libraries and the main binary.
+    @{$contained} = splice(@pcs, $start_pc_index,
+                           $finish_pc_index - $start_pc_index);
     # 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;
 
   my $debug = 0;
 
   # Ignore empty binaries
   if ($#{$pclist} < 0) { return; }
 
   # Figure out the addr2line command to use
   my $addr2line = $obj_tool_map{"addr2line"};
   my $cmd = "$addr2line -f -C -e $image";
   if (exists $obj_tool_map{"addr2line_pdb"}) {
     $addr2line = $obj_tool_map{"addr2line_pdb"};
     $cmd = "$addr2line --demangle -f -C -e $image";
   }
 
   # If "addr2line" isn't installed on the system at all, just use
   # nm to get what info we can (function names, but not line numbers).
-  if (system("$addr2line --help >/dev/null 2>&1") != 0) {
+  if (system("$addr2line --help >$dev_null 2>&1") != 0) {
     MapSymbolsWithNM($image, $offset, $pclist, $symbols);
     return;
   }
 
   # "addr2line -i" can produce a variable number of lines per input
   # address, with no separator that allows us to tell when data for
   # the next address starts.  So we find the address for a special
   # symbol (_fini) and interleave this address between all real
   # addresses passed to addr2line.  The name of this special symbol
   # can then be used as a separator.
   $sep_address = undef;  # May be filled in by MapSymbolsWithNM()
   my $nm_symbols = {};
   MapSymbolsWithNM($image, $offset, $pclist, $nm_symbols);
   # TODO(csilvers): only add '-i' if addr2line supports it.
   if (defined($sep_address)) {
     # Only add " -i" to addr2line if the binary supports it.
     # addr2line --help returns 0, but not if it sees an unknown flag first.
-    if (system("$cmd -i --help >/dev/null 2>&1") == 0) {
+    if (system("$cmd -i --help >$dev_null 2>&1") == 0) {
       $cmd .= " -i";
     } else {
       $sep_address = undef;   # no need for sep_address if we don't support -i
     }
   }
 
   # Make file with all PC values with intervening 'sep_address' so
   # that we can reliably detect the end of inlined function list
   open(ADDRESSES, ">$main::tmpfile_sym") || error("$main::tmpfile_sym: $!\n");
   if ($debug) { print("---- $image ---\n"); }
@@ skipping 125 matching lines @@
 #   1) --tools option, if set
 #   2) PPROF_TOOLS environment variable, if set
 #   3) the environment
 sub ConfigureObjTools {
   my $prog_file = shift;
 
   # Check for the existence of $prog_file because /usr/bin/file does not
   # predictably return error status in prod.
   (-e $prog_file)  || error("$prog_file does not exist.\n");
 
-  # 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`;
+  my $file_type = undef;
+  if (-e "/usr/bin/file") {
+    # Follow symlinks (at least for systems where "file" supports that).
+    $file_type = `/usr/bin/file -L $prog_file 2>$dev_null || /usr/bin/file $prog_file`;
+  } elsif ($^O == "MSWin32") {
+    $file_type = "MS Windows";
+  } else {
+    print STDERR "WARNING: Can't determine the file type of $prog_file";
+  }
+
   if ($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;
   }
 
   if ($file_type =~ /MS Windows/) {
     # For windows, we provide a version of nm and addr2line as part of
@@ skipping 18 matching lines @@
 }
 
 # Returns the path of a caller-specified object tool.  If --tools or
 # PPROF_TOOLS are specified, then returns the full path to the tool
 # with that prefix.  Otherwise, returns the path unmodified (which
 # means we will look for it on PATH).
 sub ConfigureTool {
   my $tool = shift;
   my $path;
 
-  if ($main::opt_tools ne "") {
-    # Use a prefix specified by the --tools option...
-    $path = $main::opt_tools . $tool;
-    if (!-x $path) {
-      error("No '$tool' found with prefix specified by --tools $main::opt_tools\n");
+  # --tools (or $PPROF_TOOLS) is a comma separated list, where each
+  # item is either a) a pathname prefix, or b) a map of the form
+  # <tool>:<path>.  First we look for an entry of type (b) for our
+  # tool.  If one is found, we use it.  Otherwise, we consider all the
+  # pathname prefixes in turn, until one yields an existing file.  If
+  # none does, we use a default path.
+  my $tools = $main::opt_tools || $ENV{"PPROF_TOOLS"} || "";
+  if ($tools =~ m/(,|^)\Q$tool\E:([^,]*)/) {
+    $path = $2;
+    # TODO(csilvers): sanity-check that $path exists?  Hard if it's relative.
+  } elsif ($tools ne '') {
+    foreach my $prefix (split(',', $tools)) {
+      next if ($prefix =~ /:/);    # ignore "tool:fullpath" entries in the list
+      if (-x $prefix . $tool) {
+        $path = $prefix . $tool;
+        last;
+      }
     }
-  } elsif (exists $ENV{"PPROF_TOOLS"} &&
-           $ENV{"PPROF_TOOLS"} ne "") {
-    #... or specified with the PPROF_TOOLS environment variable...
-    $path = $ENV{"PPROF_TOOLS"} . $tool;
-    if (!-x $path) {
-      error("No '$tool' found with prefix specified by PPROF_TOOLS=$ENV{PPROF_TOOLS}\n");
+    if (!$path) {
+      error("No '$tool' found with prefix specified by " .
+            "--tools (or \$PPROF_TOOLS) '$tools'\n");
     }
   } else {
     # ... otherwise use the version that exists in the same directory as
     # pprof.  If there's nothing there, use $PATH.
     $0 =~ m,[^/]*$,;     # this is everything after the last slash
     my $dirname = $`;    # this is everything up to and including the last slash
     if (-x "$dirname$tool") {
       $path = "$dirname$tool";
     } else { 
       $path = $tool;
@@ skipping 132 matching lines @@
   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.  In addition, for OS X we need
   # to use the -f flag to get 'flat' nm output (otherwise we don't sort
   # properly and get incorrect results).  Unfortunately, GNU nm uses -f
   # in an incompatible way.  So first we test whether our nm supports
   # --demangle and -f.
   my $demangle_flag = "";
   my $cppfilt_flag = "";
-  if (system("$nm --demangle $image >/dev/null 2>&1") == 0) {
+  if (system("$nm --demangle $image >$dev_null 2>&1") == 0) {
     # In this mode, we do "nm --demangle <foo>"
     $demangle_flag = "--demangle";
     $cppfilt_flag = "";
-  } elsif (system("$cppfilt $image >/dev/null 2>&1") == 0) {
+  } elsif (system("$cppfilt $image >$dev_null 2>&1") == 0) {
     # In this mode, we do "nm <foo> | c++filt"
     $cppfilt_flag = " | $cppfilt";
   };
   my $flatten_flag = "";
-  if (system("$nm -f $image >/dev/null 2>&1") == 0) {
+  if (system("$nm -f $image >$dev_null 2>&1") == 0) {
     $flatten_flag = "-f";
   }
 
   # Finally, in the case $imagie isn't a debug library, we try again with
   # -D to at least get *exported* symbols.  If we can't use --demangle,
   # we use c++filt instead, if it exists on this system.
   my @nm_commands = ("$nm -n $flatten_flag $demangle_flag" .
-                     " $image 2>/dev/null $cppfilt_flag",
+                     " $image 2>$dev_null $cppfilt_flag",
                      "$nm -D -n $flatten_flag $demangle_flag" .
-                     " $image 2>/dev/null $cppfilt_flag",
+                     " $image 2>$dev_null $cppfilt_flag",
                      # 6nm is for Go binaries
-                     "6nm $image 2>/dev/null | sort",
+                     "6nm $image 2>$dev_null | sort",
                      );
 
   # If the executable is an MS Windows PDB-format executable, we'll
   # have set up obj_tool_map("nm_pdb").  In this case, we actually
   # want to use both unix nm and windows-specific nm_pdb, since
   # PDB-format executables can apparently include dwarf .o files.
   if (exists $obj_tool_map{"nm_pdb"}) {
     my $nm_pdb = $obj_tool_map{"nm_pdb"};
-    push(@nm_commands, "$nm_pdb --demangle $image 2>/dev/null");
+    push(@nm_commands, "$nm_pdb --demangle $image 2>$dev_null");
   }
 
   foreach my $nm_command (@nm_commands) {
     my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp);
     return $symbol_table if (%{$symbol_table});
   }
   my $symbol_table = {};
   return $symbol_table;
 }
 
@@ skipping 204 matching lines @@
   $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);
 }