← Back to branch summary

~ubuntu-branches/ubuntu/jaunty/google-perftools/jaunty

« back to all changes in this revision

Viewing changes to src/pprof

  • Committer: Bazaar Package Importer
  • Author(s): Daigo Moriwaki
  • Date: 2008-06-15 23:41:36 UTC
  • mfrom: (3.1.1 sid)
  • Revision ID: james.westby@ubuntu.com-20080615234136-al5gawvdvt5vhdtz
Tags: 0.98-1
http://bugs.debian.org/425147
http://bugs.debian.org/454841
http://bugs.debian.org/450294
http://bugs.debian.org/404001
* New upstream release. (Closes: #425147)
* Compiled with GCC 4.3. (Closes: #454841)
* debian/watch: can now report upstream's version (Closes: #450294)
* Because of a file conflict between tau and libgoogle-perftools the
  binary pprof is renamed as google-pprof. (Closes: #404001)
  Great thanks to Michael Mende.
* debian/rules: autoconf files are now generated at the build time.
* Bumped up Standards-Version to 3.7.3, no changes are required.
* Split a new package, libtcmallc_minimal0. The upstream supports
  this module for wider platforms. So I leave its architecture to be
  `any'.
* libgoogle-perftools0's architecture is now i386. The upstream
  supports this module for x86 and x86_64. However, x86_64 requires
  libunwind's development head, which Debian does not have yet.
* Removed an unnecessary patch, debian/patches/02_profiler.cc_alpha.diff.

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/pprof
1
 
#! /usr/bin/perl -w
 
1
#! /usr/bin/env perl
2
2
 
3
 
# Copyright (c) 1998-2006, Google Inc.
 
3
# Copyright (c) 1998-2007, Google Inc.
4
4
# All rights reserved.
5
5
# 
6
6
# Redistribution and use in source and binary forms, with or without
69
69
# TODO: Use color to indicate files?
70
70
 
71
71
use strict;
 
72
use warnings;
72
73
use Getopt::Long;
73
74
 
74
 
my $PPROF_VERSION = "0.8";
 
75
my $PPROF_VERSION = "0.98";
75
76
 
76
77
# These are the object tools we use, which come from various sources.
77
78
# We want to invoke them directly, rather than via users' aliases and/or
88
89
);
89
90
my $DOT = "dot";          # leave non-absolute, since it may be in /usr/local
90
91
my $GV = "gv";
 
92
my $PS2PDF = "ps2pdf";
91
93
# These are used for dynamic profiles
92
94
my $WGET = "wget";
93
95
my $CURL = "curl";
101
103
my $PROGRAM_NAME_PAGE = "/pprof/cmdline";
102
104
 
103
105
 
104
 
# There is a pervasive dependency on the length (in hex characters, i.e.,
105
 
# nibbles) of an address, distinguishing between 32-bit and 64-bit profiles:
106
 
my $address_length = 8;   # Hope for 32-bit, reset if 64-bit detected.
 
106
# There is a pervasive dependency on the length (in hex characters,
 
107
# i.e., nibbles) of an address, distinguishing between 32-bit and
 
108
# 64-bit profiles.  To err on the safe size, default to 64-bit here:
 
109
my $address_length = 16;
 
110
 
 
111
# A list of paths to search for shared object files
 
112
my @prefix_list = ();
107
113
 
108
114
##### Argument parsing #####
109
115
 
133
139
   --base=<base>       Subtract <base> from <profile> before display
134
140
   --interactive       Run in interactive mode (interactive "help" gives help) [default]
135
141
   --seconds=<n>       Length of time for dynamic profiles [default=30 secs]
 
142
   --add_lib=<file>    Read additional symbols and line info from the given library
 
143
   --lib_prefix=<dir>  Comma separated list of library path prefixes
136
144
 
137
145
Reporting Granularity:
138
146
   --addresses         Report at address level
142
150
 
143
151
Output type:
144
152
   --text              Generate text report
 
153
   --callgrind         Generate callgrind format to stdout
145
154
   --gv                Generate Postscript and display
146
155
   --list=<regexp>     Generate source listing of matching routines
147
156
   --disasm=<regexp>   Generate disassembly of matching routines
170
179
   --focus=<regexp>    Focus on nodes matching <regexp>
171
180
   --ignore=<regexp>   Ignore nodes matching <regexp>
172
181
   --scale=<n>         Set GV scaling [default=0]
 
182
   --heapcheck         Make nodes with non-0 object counts
 
183
                       (i.e. direct leak generators) more visible
173
184
 
174
185
Miscellaneous:
175
186
   --tools=<prefix>    Prefix for object tool pathnames
180
191
Examples:
181
192
 
182
193
pprof /bin/ls ls.prof
 
194
                       Enters "interactive" mode
 
195
pprof --text /bin/ls ls.prof
183
196
                       Outputs one line per procedure
184
197
pprof --gv /bin/ls ls.prof
185
198
                       Displays annotated call-graph via 'gv'
191
204
                       (Per-line) annotated source listing for getdir()
192
205
pprof --disasm=getdir /bin/ls ls.prof
193
206
                       (Per-PC) annotated disassembly for getdir()
194
 
pprof localhost:1234
 
207
pprof --text localhost:1234
195
208
                       Outputs one line per procedure for localhost:1234
196
209
EOF
197
210
}
200
213
  return <<EOF
201
214
pprof (part of google-perftools $PPROF_VERSION)
202
215
 
203
 
Copyright 1998-2006 Google Inc.
 
216
Copyright 1998-2007 Google Inc.
204
217
 
205
218
This is BSD licensed software; see the source for copying conditions
206
219
and license information.
236
249
  $main::opt_lines = 0;
237
250
  $main::opt_functions = 0;
238
251
  $main::opt_files = 0;
 
252
  $main::opt_lib_prefix = "";
239
253
 
240
254
  $main::opt_text = 0;
 
255
  $main::opt_callgrind = 0;
241
256
  $main::opt_list = "";
242
257
  $main::opt_disasm = "";
243
258
  $main::opt_gv = 0;
252
267
  $main::opt_focus = '';
253
268
  $main::opt_ignore = '';
254
269
  $main::opt_scale = 0;
 
270
  $main::opt_heapcheck = 0;
255
271
  $main::opt_seconds = 30;
 
272
  $main::opt_lib = "";
256
273
 
257
274
  $main::opt_inuse_space   = 0;
258
275
  $main::opt_inuse_objects = 0;
273
290
  # Are we using $SYMBOL_PAGE?
274
291
  $main::use_symbol_page = 0;
275
292
 
276
 
  # Are we printing a heap profile?
277
 
  $main::heap_profile = 0;
278
 
 
279
 
  # Are we printing a lock profile?
280
 
  $main::lock_profile = 0;
 
293
  # Type of profile we are dealing with
 
294
  # Supported types:
 
295
  #     cpu
 
296
  #     heap
 
297
  #     growth
 
298
  #     contention
 
299
  $main::profile_type = '';     # Empty type means "unknown"
281
300
 
282
301
  GetOptions("help!"          => \$main::opt_help,
283
302
             "version!"       => \$main::opt_version,
284
303
             "cum!"           => \$main::opt_cum,
285
304
             "base=s"         => \$main::opt_base,
286
305
             "seconds=i"      => \$main::opt_seconds,
 
306
             "add_lib=s"      => \$main::opt_lib,
 
307
             "lib_prefix=s"   => \$main::opt_lib_prefix,
287
308
             "functions!"     => \$main::opt_functions,
288
309
             "lines!"         => \$main::opt_lines,
289
310
             "addresses!"     => \$main::opt_addresses,
290
311
             "files!"         => \$main::opt_files,
291
312
             "text!"          => \$main::opt_text,
 
313
             "callgrind!"     => \$main::opt_callgrind,
292
314
             "list=s"         => \$main::opt_list,
293
315
             "disasm=s"       => \$main::opt_disasm,
294
316
             "gv!"            => \$main::opt_gv,
303
325
             "focus=s"        => \$main::opt_focus,
304
326
             "ignore=s"       => \$main::opt_ignore,
305
327
             "scale=i"        => \$main::opt_scale,
 
328
             "heapcheck"      => \$main::opt_heapcheck,
306
329
             "inuse_space!"   => \$main::opt_inuse_space,
307
330
             "inuse_objects!" => \$main::opt_inuse_objects,
308
331
             "alloc_space!"   => \$main::opt_alloc_space,
361
384
  # Check output modes
362
385
  my $modes =
363
386
      $main::opt_text +
 
387
      $main::opt_callgrind +
 
388
      ($main::opt_list eq '' ? 0 : 1) +
 
389
      ($main::opt_disasm eq '' ? 0 : 1) +
364
390
      $main::opt_gv +
365
391
      $main::opt_dot +
366
392
      $main::opt_ps +
409
435
 
410
436
  # Parse profile file/location arguments
411
437
  foreach my $farg (@ARGV) {
412
 
    if ($farg =~ m/(.*)\@([0-9]+)/ ) {
 
438
    if ($farg =~ m/(.*)\@([0-9]+)(|\/.*)$/ ) {
413
439
      my $machine = $1;
414
440
      my $num_machines = $2;
 
441
      my $path = $3;
415
442
      for (my $i = 0; $i < $num_machines; $i++) {
416
 
        unshift(@main::pfile_args, "$i.$machine");
 
443
        unshift(@main::pfile_args, "$i.$machine$path");
417
444
      }
418
445
    } else {
419
446
      unshift(@main::pfile_args, $farg);
429
456
  } else {
430
457
    ConfigureObjTools($main::prog)
431
458
  }
 
459
 
 
460
  # Break the opt_list_prefix into the prefix_list array
 
461
  @prefix_list = split (',', $main::opt_lib_prefix);
 
462
 
 
463
  # Remove trailing / from the prefixes, in the list to prevent
 
464
  # searching things like /my/path//lib/mylib.so
 
465
  foreach (@prefix_list) {
 
466
    s|/+$||;
 
467
  }
432
468
}
433
469
 
434
470
sub Main() {
443
479
  # Read one profile, pick the last item on the list
444
480
  my $data = ReadProfile($main::prog, pop(@main::profile_files));
445
481
  my $profile = $data->{profile};
 
482
  my $pcs = $data->{pcs};
446
483
  my $libs = $data->{libs};   # Info about main program and shared libraries
447
484
 
448
 
  # List of function names to skip
449
 
  $main::skip = ();
450
 
  $main::skip_regexp = 'NOMATCH';
451
 
  if ($main::heap_profile) {
452
 
    foreach my $name ('calloc',
453
 
                      'cfree',
454
 
                      'malloc',
455
 
                      'free',
456
 
                      'memalign',
457
 
                      'pvalloc',
458
 
                      'valloc',
459
 
                      'realloc',
460
 
                      'do_malloc',
461
 
                      'DoSampledAllocation',
462
 
                      'simple_alloc::allocate',
463
 
                      '__malloc_alloc_template::allocate',
464
 
                      '__builtin_delete',
465
 
                      '__builtin_new',
466
 
                      '__builtin_vec_delete',
467
 
                      '__builtin_vec_new') {
468
 
      $main::skip{$name} = 1;
469
 
    }
470
 
    $main::skip_regexp = "TCMalloc";
471
 
  }
472
 
  if ($main::lock_profile) {
473
 
    foreach my $vname ('Mutex::Unlock', 'Mutex::UnlockSlow') {
474
 
      $main::skip{$vname} = 1;
475
 
    }
476
 
  }
477
 
 
478
485
  # Add additional profiles, if available.
479
486
  if (scalar(@main::profile_files) > 0) {
480
487
    foreach my $pname (@main::profile_files) {
481
 
      my $p = ReadProfile($main::prog, $pname)->{profile};
482
 
      $profile = AddProfile($profile, $p);
 
488
      my $data2 = ReadProfile($main::prog, $pname);
 
489
      $profile = AddProfile($profile, $data2->{profile});
 
490
      $pcs = AddPcs($pcs, $data2->{pcs});
483
491
    }
484
492
  }
485
493
 
495
503
  # Collect symbols
496
504
  my $symbols = undef;
497
505
  if ($main::use_symbol_page) {
498
 
    $symbols = FetchSymbols($data->{pcs});
 
506
    $symbols = FetchSymbols($pcs);
499
507
  } else {
500
 
    $symbols = ExtractSymbols($libs, $profile, $data->{pcs});
 
508
    $symbols = ExtractSymbols($libs, $profile, $pcs);
501
509
  }
502
510
 
 
511
  my $calls = ExtractCalls($symbols, $profile);
 
512
 
 
513
  # Remove uniniteresting stack items
 
514
  $profile = RemoveUninterestingFrames($symbols, $profile);
 
515
 
503
516
  # Focus?
504
517
  if ($main::opt_focus ne '') {
505
518
    $profile = FocusProfile($symbols, $profile, $main::opt_focus);
526
539
      PrintListing($libs, $flat, $cumulative, $main::opt_list);
527
540
    } elsif ($main::opt_text) {
528
541
      PrintText($symbols, $flat, $cumulative, $total, -1);
 
542
    } elsif ($main::opt_callgrind) {
 
543
      PrintCallgrind($calls);
529
544
    } else {
530
545
      if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
531
546
        if ($main::opt_gv) {
532
 
          if (!system("$GV --version >/dev/null 2>&1")) {
533
 
            # Options using double dash are supported by this gv version.
534
 
            system("$GV --scale=$main::opt_scale " .
535
 
                   PsTempName($main::next_tmpfile));
536
 
          } else {
537
 
            # Old gv version - only supports options that use single dash.
538
 
            system("$GV -scale $main::opt_scale " .
539
 
                   PsTempName($main::next_tmpfile));
540
 
          }
 
547
          RunGV(PsTempName($main::next_tmpfile), "");
541
548
        }
542
549
      } else {
543
550
        exit(1);
568
575
  }
569
576
}
570
577
 
 
578
sub RunGV {
 
579
  my $fname = shift;
 
580
  my $bg = shift;       # "" or " &" if we should run in background
 
581
  if (!system("$GV --version >/dev/null 2>&1")) {
 
582
    # Options using double dash are supported by this gv version.
 
583
    # Also, turn on noantialias to better handle bug in gv for
 
584
    # postscript files with large dimensions.
 
585
    # TODO: Maybe we should not pass the --noantialias flag
 
586
    # if the gv version is known to work properly without the flag.
 
587
    system("$GV --scale=$main::opt_scale --noantialias " . $fname . $bg);
 
588
  } else {
 
589
    # Old gv version - only supports options that use single dash.
 
590
    print STDERR "$GV -scale $main::opt_scale\n";
 
591
    system("$GV -scale $main::opt_scale " . $fname . $bg);
 
592
  }
 
593
}
 
594
 
 
595
 
571
596
##### Interactive helper routines #####
572
597
 
573
598
sub InteractiveMode {
574
599
  $| = 1;  # Make output unbuffered for interactive mode
575
600
  my ($orig_profile, $symbols, $libs, $total) = @_;
576
601
 
 
602
  print "Welcome to pprof!  For help, type 'help'.\n";
 
603
 
577
604
  # Use ReadLine if it's installed.
578
605
  if ( !ReadlineMightFail() &&
579
606
       defined(eval {require Term::ReadLine}) ) {
620
647
  }
621
648
  # Clear all the mode options -- mode is controlled by "$command"
622
649
  $main::opt_text = 0;
 
650
  $main::opt_callgrind = 0;
623
651
  $main::opt_disasm = 0;
624
652
  $main::opt_list = 0;
625
653
  $main::opt_gv = 0;
695
723
    my $cumulative = CumulativeProfile($reduced);
696
724
 
697
725
    if (PrintDot($main::prog, $symbols, $profile, $flat, $cumulative, $total)) {
698
 
      if (!system("$GV --version >/dev/null 2>&1")) {
699
 
        # Options using double dash are supported by this gv version.
700
 
        system("$GV --scale=$main::opt_scale --noresize " .
701
 
               PsTempName($main::next_tmpfile) . " &");
702
 
      } else {
703
 
        # Old gv version - only supports options that use single dash.
704
 
        system("$GV -scale $main::opt_scale -noresize " .
705
 
               PsTempName($main::next_tmpfile) . " &");
706
 
      }
 
726
      RunGV(PsTempName($main::next_tmpfile), " &");
707
727
      $main::next_tmpfile++;
708
728
    }
709
729
    return 1;
780
800
Further pprof details are available at this location (or one similar):
781
801
 
782
802
 /usr/doc/google-perftools-$PPROF_VERSION/cpu_profiler.html
 
803
 /usr/doc/google-perftools-$PPROF_VERSION/heap_profiler.html
783
804
 
784
805
ENDOFHELP
785
806
}
853
874
  }
854
875
}
855
876
 
 
877
# Print the call graph in a way that's suiteable for callgrind.
 
878
sub PrintCallgrind {
 
879
  my $calls = shift;
 
880
  printf("events: Hits\n\n");
 
881
  foreach my $call ( map { $_->[0] }
 
882
                     sort { $a->[1] cmp $b ->[1] ||
 
883
                            $a->[2] <=> $b->[2] }
 
884
                     map { /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/; 
 
885
                           [$_, $1, $2] }
 
886
                     keys %$calls ) {
 
887
    my $count = $calls->{$call};
 
888
    $call =~ /([^:]+):(\d+):([^ ]+)( -> ([^:]+):(\d+):(.+))?/;
 
889
    my ( $caller_file, $caller_line, $caller_function,
 
890
         $callee_file, $callee_line, $callee_function ) =
 
891
       ( $1, $2, $3, $5, $6, $7 );
 
892
    printf("fl=$caller_file\nfn=$caller_function\n");
 
893
    if (defined $6) {
 
894
      printf("cfl=$callee_file\n");
 
895
      printf("cfn=$callee_function\n");
 
896
      printf("calls=$count $callee_line\n");
 
897
    }
 
898
    printf("$caller_line $count\n\n");
 
899
  }
 
900
}
 
901
 
856
902
# Print disassembly for all all routines that match $main::opt_disasm
857
903
sub PrintDisassembly {
858
904
  my $libs = shift;
904
950
               $address,
905
951
               $e->[3]);
906
952
      }
907
 
      close(OBJDUMP);
908
953
    }
909
954
  }
910
955
}
1003
1048
  # Disassemble all instructions (just to get line numbers)
1004
1049
  my @instructions = Disassemble($prog, $offset, $start_addr, $end_addr);
1005
1050
 
1006
 
  # Hack 1: assume that the last source location mentioned in the
1007
 
  # disassembly is the end of the source code.
 
1051
  # Hack 1: assume that the first source file encountered in the
 
1052
  # disassembly contains the routine
1008
1053
  my $filename = undef;
1009
 
  my $lastline = -1;
1010
 
  for (my $i = $#instructions; $i >= 0; $i--) {
 
1054
  for (my $i = 0; $i <= $#instructions; $i++) {
1011
1055
    if ($instructions[$i]->[2] >= 0) {
1012
1056
      $filename = $instructions[$i]->[1];
1013
 
      $lastline = $instructions[$i]->[2];
1014
1057
      last;
1015
1058
    }
1016
1059
  }
1019
1062
    return;
1020
1063
  }
1021
1064
 
1022
 
  # Hack 2: assume the first source location from "filename" is the start of
 
1065
  # Hack 2: assume that the largest line number from $filename is the
 
1066
  # end of the procedure.  This is typically safe since if P1 contains
 
1067
  # an inlined call to P2, then P2 usually occurs earlier in the
 
1068
  # source file.  If this does not work, we might have to compute a
 
1069
  # density profile or just print all regions we find.
 
1070
  my $lastline = 0;
 
1071
  for (my $i = 0; $i <= $#instructions; $i++) {
 
1072
    my $f = $instructions[$i]->[1];
 
1073
    my $l = $instructions[$i]->[2];
 
1074
    if (($f eq $filename) && ($l > $lastline)) {
 
1075
      $lastline = $l;
 
1076
    }
 
1077
  }
 
1078
 
 
1079
  # Hack 3: assume the first source location from "filename" is the start of
1023
1080
  # the source code.
1024
1081
  my $firstline = 1;
1025
1082
  for (my $i = 0; $i <= $#instructions; $i++) {
1029
1086
    }
1030
1087
  }
1031
1088
 
1032
 
  # Hack 3: Extend last line forward until its indentation is less than
 
1089
  # Hack 4: Extend last line forward until its indentation is less than
1033
1090
  # the indentation we saw on $firstline
1034
1091
  my $oldlastline = $lastline;
1035
1092
  {
1110
1167
        (($l <= $oldlastline + 5) || ($l <= $lastline))) {
1111
1168
      chop;
1112
1169
      my $text = $_;
 
1170
      if ($l == $firstline) { printf("---\n"); }
1113
1171
      printf("%6s %6s %4d: %s\n",
1114
1172
             UnparseAlt(GetEntry($samples1, $l)),
1115
1173
             UnparseAlt(GetEntry($samples2, $l)),
1116
1174
             $l,
1117
1175
             $text);
 
1176
      if ($l == $lastline)  { printf("---\n"); }
1118
1177
    };
1119
1178
  }
1120
1179
  close(FILE);
1166
1225
  } elsif ($main::opt_ps) {
1167
1226
    $output = "| $DOT -Tps";
1168
1227
  } elsif ($main::opt_pdf) {
1169
 
    $output = "| $DOT -Tps | ps2pdf - -";
 
1228
    $output = "| $DOT -Tps | $PS2PDF - -";
1170
1229
  } elsif ($main::opt_gif) {
1171
1230
    $output = "| $DOT -Tgif";
1172
1231
  } else {
1222
1281
                       Unparse($c),
1223
1282
                       Percent($c, $overall_total));
1224
1283
    }
 
1284
    my $style = "";
 
1285
    if ($main::opt_heapcheck) {
 
1286
      if ($f > 0) {
 
1287
        # make leak-causing nodes more visible (add a background)
 
1288
        $style = ",style=filled,fillcolor=gray"
 
1289
      } elsif ($f < 0) {
 
1290
        # make anti-leak-causing nodes (which almost never occur)
 
1291
        # stand out as well (triple border)
 
1292
        $style = ",peripheries=3"
 
1293
      }
 
1294
    }
 
1295
 
1225
1296
    printf DOT ("N%d [label=\"%s\\n%s (%s)%s\\r" .
1226
 
                "\",shape=box,fontsize=%.1f];\n",
 
1297
                "\",shape=box,fontsize=%.1f%s];\n",
1227
1298
                $node{$a},
1228
1299
                $sym,
1229
1300
                Unparse($f),
1230
1301
                Percent($f, $overall_total),
1231
1302
                $extra,
1232
1303
                $fs,
 
1304
                $style,
1233
1305
               );
1234
1306
  }
1235
1307
 
1266
1338
      my $w = $fraction * 2;
1267
1339
      #if ($w < 1) { $w = 1; }
1268
1340
 
 
1341
      # Dot sometimes segfaults if given edge weights that are too large, so
 
1342
      # we cap the weights at a large value
 
1343
      my $edgeweight = abs($n) ** 0.7;
 
1344
      if ($edgeweight > 100000) { $edgeweight = 100000; }
 
1345
      $edgeweight = int($edgeweight);
 
1346
 
1269
1347
      # Use a slightly squashed function of the edge count as the weight
1270
1348
      printf DOT ("N%s -> N%s [label=%s, weight=%d, " .
1271
1349
                  "style=\"setlinewidth(%f)\"];\n",
1272
1350
                  $node{$x[0]},
1273
1351
                  $node{$x[1]},
1274
1352
                  Unparse($n),
1275
 
                  int(abs($n) ** 0.7),
 
1353
                  $edgeweight,
1276
1354
                  $w);
1277
1355
    }
1278
1356
  }
1304
1382
    $fileline = $symbols->{$a}->[1];
1305
1383
  }
1306
1384
 
1307
 
  # We drop a few well-known names
1308
 
  if ($main::skip{$func} || ($func =~ m/$main::skip_regexp/)) {
1309
 
    return '';
1310
 
  }
1311
 
 
1312
1385
  if ($main::opt_disasm || $main::opt_list) {
1313
1386
    return $a;   # We want just the address for the key
1314
1387
  } elsif ($main::opt_addresses) {
1340
1413
# Generate pretty-printed form of number
1341
1414
sub Unparse {
1342
1415
  my $num = shift;
1343
 
  if ($main::heap_profile) {
 
1416
  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
1344
1417
    if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
1345
1418
      return sprintf("%d", $num);
1346
1419
    } else {
1350
1423
        return sprintf("%.1f", $num / 1048576.0);
1351
1424
      }
1352
1425
    }
1353
 
  } elsif ($main::lock_profile && !$main::opt_contentions) {
 
1426
  } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
1354
1427
    return sprintf("%.3f", $num / 1e9); # Convert nanoseconds to seconds
1355
1428
  } else {
1356
1429
    return sprintf("%d", $num);
1369
1442
 
1370
1443
# Return output units
1371
1444
sub Units {
1372
 
  if ($main::heap_profile) {
 
1445
  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
1373
1446
    if ($main::opt_inuse_objects || $main::opt_alloc_objects) {
1374
1447
      return "objects";
1375
1448
    } else {
1379
1452
        return "MB";
1380
1453
      }
1381
1454
    }
1382
 
  } elsif ($main::lock_profile && !$main::opt_contentions) {
 
1455
  } elsif ($main::profile_type eq 'contention' && !$main::opt_contentions) {
1383
1456
    return "seconds";
1384
1457
  } else {
1385
1458
    return "samples";
1420
1493
  return $result;
1421
1494
}
1422
1495
 
 
1496
# If the second-youngest PC on the stack is always the same, returns
 
1497
# that pc.  Otherwise, returns undef.
 
1498
sub IsSecondPcAlwaysTheSame {
 
1499
  my $profile = shift;
 
1500
 
 
1501
  my $second_pc = undef;
 
1502
  foreach my $k (keys(%{$profile})) {
 
1503
    my @addrs = split(/\n/, $k);
 
1504
    if ($#addrs < 1) {
 
1505
      return undef;
 
1506
    }
 
1507
    if (not defined $second_pc) {
 
1508
      $second_pc = $addrs[1];
 
1509
    } else {
 
1510
      if ($second_pc ne $addrs[1]) {
 
1511
        return undef;
 
1512
      }
 
1513
    }
 
1514
  }
 
1515
  return $second_pc;
 
1516
}
 
1517
 
 
1518
# Extracts a graph of calls.
 
1519
sub ExtractCalls {
 
1520
  my $symbols = shift;
 
1521
  my $profile = shift;
 
1522
 
 
1523
  my $calls = {};
 
1524
  while( my ($stack_trace, $count) = each %$profile ) {
 
1525
    my @address = split(/\n/, $stack_trace);
 
1526
    for (my $i = 1; $i <= $#address; $i++) {
 
1527
      if (exists $symbols->{$address[$i]}) {
 
1528
        my $source = $symbols->{$address[$i]}->[1] . ":" . 
 
1529
                     $symbols->{$address[$i]}->[0];
 
1530
        my $destination = $symbols->{$address[$i-1]}->[1] . ":" . 
 
1531
                          $symbols->{$address[$i-1]}->[0];
 
1532
        my $call = "$source -> $destination";
 
1533
        AddEntry($calls, $call, $count);
 
1534
 
 
1535
        if ($i == 1) {
 
1536
          AddEntry($calls, $destination, $count);
 
1537
        }
 
1538
      }
 
1539
    }
 
1540
  }
 
1541
 
 
1542
  return $calls;
 
1543
}
 
1544
 
 
1545
sub RemoveUninterestingFrames {
 
1546
  my $symbols = shift;
 
1547
  my $profile = shift;
 
1548
 
 
1549
  # List of function names to skip
 
1550
  my %skip = ();
 
1551
  my $skip_regexp = 'NOMATCH';
 
1552
  if ($main::profile_type eq 'heap' || $main::profile_type eq 'growth') {
 
1553
    foreach my $name ('calloc',
 
1554
                      'cfree',
 
1555
                      'malloc',
 
1556
                      'free',
 
1557
                      'memalign',
 
1558
                      'pvalloc',
 
1559
                      'valloc',
 
1560
                      'realloc',
 
1561
                      'do_malloc',
 
1562
                      'DoSampledAllocation',
 
1563
                      'simple_alloc::allocate',
 
1564
                      '__malloc_alloc_template::allocate',
 
1565
                      '__builtin_delete',
 
1566
                      '__builtin_new',
 
1567
                      '__builtin_vec_delete',
 
1568
                      '__builtin_vec_new',
 
1569
                      'operator new',
 
1570
                      'operator new[]') {
 
1571
      $skip{$name} = 1;
 
1572
    }
 
1573
    $skip_regexp = "TCMalloc";
 
1574
  } elsif ($main::profile_type eq 'contention') {
 
1575
    foreach my $vname ('Mutex::Unlock', 'Mutex::UnlockSlow') {
 
1576
      $skip{$vname} = 1;
 
1577
    }
 
1578
  } elsif ($main::profile_type eq 'cpu') {
 
1579
    # Drop signal handlers used for CPU profile collection
 
1580
    # TODO(dpeng): this should not be necessary; it's taken
 
1581
    # care of by the general 2nd-pc mechanism below.
 
1582
    foreach my $name ('ProfileData::Add',           # historical
 
1583
                      'ProfileData::prof_handler',  # historical
 
1584
                      'CpuProfiler::prof_handler',
 
1585
                      '__pthread_sighandler',
 
1586
                      '__restore') {
 
1587
      $skip{$name} = 1;
 
1588
    }
 
1589
  } else {
 
1590
    # Nothing skipped for unknown types
 
1591
  }
 
1592
 
 
1593
  if ($main::profile_type eq 'cpu') {
 
1594
    # If all the second-youngest program counters are the same,
 
1595
    # this STRONGLY suggests that it is an artifact of measurement,
 
1596
    # i.e., stack frames pushed by the CPU profiler signal handler.
 
1597
    # Hence, we delete them.
 
1598
    # (The topmost PC is read from the signal structure, not from
 
1599
    # the stack, so it does not get involved.)
 
1600
    while (my $second_pc = IsSecondPcAlwaysTheSame($profile)) {
 
1601
      my $result = {};
 
1602
      my $func = '';
 
1603
      if (exists($symbols->{$second_pc})) {
 
1604
        $second_pc = $symbols->{$second_pc}->[0];
 
1605
      }
 
1606
      print STDERR "Removing $second_pc from all stack traces.\n";
 
1607
      foreach my $k (keys(%{$profile})) {
 
1608
        my $count = $profile->{$k};
 
1609
        my @addrs = split(/\n/, $k);
 
1610
        splice @addrs, 1, 1;
 
1611
        my $reduced_path = join("\n", @addrs);
 
1612
        AddEntry($result, $reduced_path, $count);
 
1613
      }
 
1614
      $profile = $result;
 
1615
    }
 
1616
  }
 
1617
 
 
1618
  my $result = {};
 
1619
  foreach my $k (keys(%{$profile})) {
 
1620
    my $count = $profile->{$k};
 
1621
    my @addrs = split(/\n/, $k);
 
1622
    my @path = ();
 
1623
    foreach my $a (@addrs) {
 
1624
      if (exists($symbols->{$a})) {
 
1625
        my $func = $symbols->{$a}->[0];
 
1626
        if ($skip{$func} || ($func =~ m/$skip_regexp/)) {
 
1627
          next;
 
1628
        }
 
1629
      }
 
1630
      push(@path, $a);
 
1631
    }
 
1632
    my $reduced_path = join("\n", @path);
 
1633
    AddEntry($result, $reduced_path, $count);
 
1634
  }
 
1635
  return $result;
 
1636
}
 
1637
 
1423
1638
# Reduce profile to granularity given by user
1424
1639
sub ReduceProfile {
1425
1640
  my $symbols = shift;
1436
1651
      # entry if it has already been seen
1437
1652
      my $key = OutputKey($symbols, $a);
1438
1653
      if (!$seen{$key}) {
1439
 
        $seen{$key} = 1;
1440
 
        push(@path, $key);
 
1654
        $seen{$key} = 1;
 
1655
        push(@path, $key);
1441
1656
      }
1442
1657
    }
1443
1658
    my $reduced_path = join("\n", @path);
1525
1740
  return $R;
1526
1741
}
1527
1742
 
 
1743
# Add A to B
 
1744
sub AddPcs {
 
1745
  my $A = shift;
 
1746
  my $B = shift;
 
1747
 
 
1748
  my $R = {};
 
1749
  # add all keys in A
 
1750
  foreach my $k (keys(%{$A})) {
 
1751
    $R->{$k} = 1
 
1752
  }
 
1753
  # add all keys in B
 
1754
  foreach my $k (keys(%{$B})) {
 
1755
    $R->{$k} = 1
 
1756
  }
 
1757
  return $R;
 
1758
}
 
1759
 
1528
1760
# Subtract B from A
1529
1761
sub SubtractProfile {
1530
1762
  my $A = shift;
1616
1848
 
1617
1849
sub ParseProfileURL {
1618
1850
  my $profile_name = shift;
1619
 
  if ($profile_name =~ m,^(http://|)([^/:]+):(\d+)(|/|$PROFILE_PAGE|$HEAP_PAGE|$GROWTH_PAGE|$CONTENTION_PAGE)$,o) {
1620
 
    return ($2, $3, $4);
 
1851
  if (defined($profile_name) &&
 
1852
      $profile_name =~ m,^(http://|)([^/:]+):(\d+)(|\@\d+)(|/|$PROFILE_PAGE|$HEAP_PAGE|$GROWTH_PAGE|$CONTENTION_PAGE)$,o) {
 
1853
    return ($2, $3, $5);
1621
1854
  }
1622
1855
  return ();
1623
1856
}
1671
1904
 
1672
1905
  my $url = SymbolPageURL();
1673
1906
  # Here we use curl for sending data via POST since old
1674
 
  # wgets don't't have --post-file option.
 
1907
  # wget doesn't have --post-file option.
1675
1908
  $url = ResolveRedirectionForCurl($url);
1676
1909
  my $command_line = "$CURL -sd '\@$main::tmpfile_sym' '$url'";
1677
1910
  # We use c++filt in case $SYMBOL_PAGE gives us mangled symbols.
1680
1913
 
1681
1914
  my %map;
1682
1915
  while (<SYMBOL>) {
1683
 
    if (m/^0x([0-9a-f]+)\s+(.+)/) {
 
1916
    # Removes all the leading zeroes from the symbols, see comment below.
 
1917
    if (m/^0x0*([0-9a-f]+)\s+(.+)/) {
1684
1918
      $map{$1} = $2;
1685
1919
    }
1686
1920
  }
1689
1923
  my $symbols = {};
1690
1924
  for my $pc (@pcs) {
1691
1925
    my $fullname;
1692
 
    if (defined($map{$pc})) {
1693
 
      $fullname = $map{$pc};
 
1926
    # For 64 bits binaries, symbols are extracted with 8 leading zeroes.
 
1927
    # Then /symbolz reads the long symbols in as uint64, and outputs
 
1928
    # the result with a "0x%08llx" format which get rid of the zeroes.
 
1929
    # By removing all the leading zeroes in both $pc and the symbols from
 
1930
    # /symbolz, the symbols match and are retrievable from the map.
 
1931
    my $shortpc = $pc;
 
1932
    $shortpc =~ s/^0*//;
 
1933
    if (defined($map{$shortpc})) {
 
1934
      $fullname = $map{$shortpc};
1694
1935
    } else {
1695
1936
      $fullname = "0x" . $pc;  # Just use addresses
1696
1937
    }
1720
1961
  my $fetch_name_only = shift;
1721
1962
  my $encourage_patience = shift;
1722
1963
 
1723
 
  my $user_dir = $ENV{HOME};
1724
 
  my $profile_dir = $user_dir . "/pprof";
1725
 
  if (!(-d $profile_dir)) {
1726
 
    mkdir($profile_dir) || die("Unable to create profile directory $profile_dir\n");
1727
 
  }
1728
1964
  if (!IsProfileURL($profile_name)) {
1729
1965
    return $profile_name;
1730
1966
  } else {
1752
1988
      $url = "http://$host:$port$type";
1753
1989
      $wget_timeout = "";
1754
1990
    }
 
1991
 
 
1992
    my $profile_dir = $ENV{"PPROF_TMPDIR"} || ($ENV{HOME} . "/pprof");
 
1993
    if (!(-d $profile_dir)) {
 
1994
      mkdir($profile_dir)
 
1995
          || die("Unable to create profile directory $profile_dir: $!\n");
 
1996
    }
1755
1997
    my $tmp_profile = "$profile_dir/.tmp.$profile_file";
1756
1998
    my $real_profile = "$profile_dir/$profile_file";
1757
1999
 
1845
2087
  my $prog = shift;
1846
2088
  my $fname = shift;
1847
2089
 
1848
 
  $main::heap_profile = 0;
1849
 
  $main::lock_profile = 0;
 
2090
  $main::profile_type = '';
1850
2091
 
1851
2092
  # Look at first line to see if it is a heap or a CPU profile
1852
2093
  open(PROFILE, "<$fname") || error("$fname: $!\n");
1853
2094
  binmode PROFILE;      # New perls do UTF-8 processing
1854
2095
  my $header = <PROFILE>;
1855
2096
  my $contention_marker = substr($CONTENTION_PAGE, 1);   # remove leading /
1856
 
  if ($header =~ m/^heap profile:/) {
1857
 
    $main::heap_profile = 1;
 
2097
  if ($header =~ m/^heap profile:.*growthz/) {
 
2098
    $main::profile_type = 'growth';
 
2099
    return ReadHeapProfile($prog, $fname, $header);
 
2100
  } elsif ($header =~ m/^heap profile:/) {
 
2101
    $main::profile_type = 'heap';
1858
2102
    return ReadHeapProfile($prog, $fname, $header);
1859
2103
  } elsif ($header =~ m/^--- *$contention_marker/o ) {
1860
 
    $main::lock_profile = 1;
 
2104
    $main::profile_type = 'contention';
1861
2105
    return ReadSynchProfile($prog, $fname);
1862
2106
  } elsif ($header =~ m/^--- *Stacks:/ ) {
1863
2107
    print STDERR
1864
2108
      "Old format contention profile: mistakenly reports " .
1865
2109
      "condition variable signals as lock contentions.\n";
1866
 
    $main::lock_profile = 1;
 
2110
    $main::profile_type = 'contention';
1867
2111
    return ReadSynchProfile($prog, $fname);
1868
2112
  } else {
1869
2113
    # Need to unread the line we just read
 
2114
    $main::profile_type = 'cpu';
1870
2115
    close(PROFILE);
1871
2116
    open(PROFILE, "<$fname") || error("$fname: $!\n");
1872
2117
    binmode PROFILE;    # New perls do UTF-8 processing
2159
2404
      # Convert cycles to nanoseconds
2160
2405
      $cycles /= $cyclespernanosec;
2161
2406
 
 
2407
      # Adjust for sampling done by application
 
2408
      $cycles *= $sampling_period;
 
2409
      $count *= $sampling_period;
 
2410
 
2162
2411
      my @values = ($cycles, $count, $cycles / $count);
2163
2412
      AddEntries($profile, $pcs, $stack, $values[$index]);
2164
2413
 
2171
2420
 
2172
2421
      # Convert cycles to nanoseconds
2173
2422
      $cycles /= $cyclespernanosec;
 
2423
 
 
2424
      # Adjust for sampling done by application
 
2425
      $cycles *= $sampling_period;
 
2426
 
2174
2427
      AddEntries($profile, $pcs, $stack, $cycles);
2175
2428
 
2176
 
    } elsif ( $line =~ m|cycles/second = (\d+)|) {
2177
 
      $cyclespernanosec = $1 / 1e9;
2178
 
      $seen_clockrate = 1;
2179
 
    } elsif ( $line =~ /sampling period = (\d+)/ ) {
2180
 
      $sampling_period = $1;
2181
 
 
 
2429
    } elsif ( $line =~ m/^([^=]*)=(.*)$/ ) {
 
2430
      my ($variable, $value) = ($1,$2);
 
2431
      for ($variable, $value) {
 
2432
        s/^\s+//;
 
2433
        s/\s+$//;
 
2434
      }
 
2435
      if($variable eq "cycles/second") {
 
2436
        $cyclespernanosec = $value / 1e9;
 
2437
        $seen_clockrate = 1;
 
2438
      } elsif ($variable eq "sampling period") {
 
2439
        $sampling_period = $value;
 
2440
      } elsif ($variable eq "ms since reset") {
 
2441
        # Currently nothing is done with this value in pprof
 
2442
        # So we just silently ignore it for now
 
2443
      } elsif ($variable eq "discarded samples") {
 
2444
        # Currently nothing is done with this value in pprof
 
2445
        # So we just silently ignore it for now
 
2446
      } else {
 
2447
        printf STDERR ("Ignoring unnknown variable in /contentionz output: " .
 
2448
                       "'%s' = '%s'\n",$variable,$value);
 
2449
      }
2182
2450
    } else {
2183
2451
      # Memory map entry
2184
2452
      $map .= $line;
2207
2475
  my $addr = shift;
2208
2476
 
2209
2477
  $addr =~ s/^0x//;
 
2478
 
 
2479
  if (length $addr > $address_length) {
 
2480
    printf STDERR "Warning:  address $addr is longer than address length $address_length\n";
 
2481
  }
 
2482
 
2210
2483
  return substr("000000000000000".$addr, -$address_length);
2211
2484
}
2212
2485
 
2213
2486
##### Symbol extraction #####
2214
2487
 
 
2488
# Aggressively search the lib_prefix values for the given library
 
2489
# If all else fails, just return the name of the library unmodified.
 
2490
# If the lib_prefix is "/my/path,/other/path" and $file is "/lib/dir/mylib.so"
 
2491
# it will search the following locations in this order, until it finds a file:
 
2492
#   /my/path/lib/dir/mylib.so
 
2493
#   /other/path/lib/dir/mylib.so
 
2494
#   /my/path/dir/mylib.so
 
2495
#   /other/path/dir/mylib.so
 
2496
#   /my/path/mylib.so
 
2497
#   /other/path/mylib.so
 
2498
#   /lib/dir/mylib.so              (returned as last resort)
 
2499
sub FindLibrary {
 
2500
  my $file = shift;
 
2501
  my $suffix = $file;
 
2502
 
 
2503
  # Search for the library as described above
 
2504
  do {
 
2505
    foreach my $prefix (@prefix_list) {
 
2506
      my $fullpath = $prefix . $suffix;
 
2507
      if (-e $fullpath) {
 
2508
        return $fullpath;
 
2509
      }
 
2510
    }
 
2511
  } while ($suffix =~ s|^/[^/]+/|/|);
 
2512
  return $file;
 
2513
}
 
2514
 
 
2515
# Return path to library with debugging symbols.
 
2516
# For libc libraries, the copy in /usr/lib/debug contains debugging symbols
 
2517
sub DebuggingLibrary {
 
2518
  my $file = shift;
 
2519
  if ($file =~ m|^/| && -f "/usr/lib/debug$file") {
 
2520
    return "/usr/lib/debug$file";
 
2521
  }
 
2522
  return undef;
 
2523
}
 
2524
 
 
2525
# Parse text section header of a library using objdump
 
2526
sub ParseTextSectionHeader {
 
2527
   my $lib = shift;
 
2528
 
 
2529
   my $size = undef;
 
2530
   my $vma;
 
2531
   my $file_offset;
 
2532
   # Get objdump output from the library file to figure out how to
 
2533
   # map between mapped addresses and addresses in the library.
 
2534
   my $objdump = $obj_tool_map{"objdump"};
 
2535
   open(OBJDUMP, "$objdump -h $lib |")
 
2536
                 || error("$objdump $lib: $!\n");
 
2537
   while (<OBJDUMP>) {
 
2538
     # Idx Name          Size      VMA       LMA       File off  Algn
 
2539
     #  10 .text         00104b2c  420156f0  420156f0  000156f0  2**4
 
2540
     # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file
 
2541
     # offset may still be 8.  But AddressSub below will still handle that.
 
2542
     my @x = split;
 
2543
     if (($#x >= 6) && ($x[1] eq '.text')) {
 
2544
       $size = $x[2];
 
2545
       $vma = $x[3];
 
2546
       $file_offset = $x[5];
 
2547
       last;
 
2548
     }
 
2549
   }
 
2550
   close(OBJDUMP);
 
2551
 
 
2552
   if (!defined($size)) {
 
2553
      return undef;
 
2554
   }
 
2555
 
 
2556
   my $r = {};
 
2557
   $r->{size} = $size;
 
2558
   $r->{vma} = $vma;
 
2559
   $r->{file_offset} = $file_offset;
 
2560
 
 
2561
   return $r;
 
2562
}
 
2563
 
2215
2564
# Split /proc/pid/maps dump into a list of libraries
2216
2565
sub ParseLibraries {
2217
2566
  return if $main::use_symbol_page;  # We don't need libraries info.
2254
2603
    # Expand "$build" variable if available
2255
2604
    $lib =~ s/\$build\b/$buildvar/g;
2256
2605
 
2257
 
    # Get objdump output from the library file to figure out how to
2258
 
    # map between mapped addresses and addresses in the library.
2259
 
    my $objdump = $obj_tool_map{"objdump"};
2260
 
    open(OBJDUMP, "$objdump -h $lib |")
2261
 
                  || error("$objdump $lib: $!\n");
2262
 
    while (<OBJDUMP>) {
2263
 
      # Idx Name          Size      VMA       LMA       File off  Algn
2264
 
      #  10 .text         00104b2c  420156f0  420156f0  000156f0  2**4
2265
 
      # For 64-bit objects, VMA and LMA will be 16 hex digits, size and file
2266
 
      # offset may still be 8.  But AddressSub below will still handle that.
2267
 
      my @x = split;
2268
 
      if (($#x >= 6) && ($x[1] eq '.text')) {
2269
 
        my $vma = $x[3];
2270
 
        my $file_offset = $x[5];
2271
 
        my $vma_offset = AddressSub($vma, $file_offset);
2272
 
        $offset = AddressAdd($offset, $vma_offset);
2273
 
        last;
 
2606
    $lib = FindLibrary($lib);
 
2607
 
 
2608
    # Check for pre-relocated libraries, which use pre-relocated symbol tables
 
2609
    # and thus require adjusting the offset that we'll use to translate
 
2610
    # VM addresses into symbol table addresses.
 
2611
    # Only do this if we're not going to fetch the symbol table from a 
 
2612
    # debugging copy of the library.
 
2613
    if (!DebuggingLibrary($lib)) {
 
2614
      my $text = ParseTextSectionHeader($lib);
 
2615
      if (defined($text)) {
 
2616
         my $vma_offset = AddressSub($text->{vma}, $text->{file_offset});
 
2617
         $offset = AddressAdd($offset, $vma_offset);
2274
2618
      }
2275
2619
    }
2276
 
    close(OBJDUMP);
2277
2620
 
2278
2621
    push(@{$result}, [$lib, $start, $finish, $offset]);
2279
2622
  }
2280
2623
 
 
2624
  # Append special entry for additional library (not relocated)
 
2625
  if ($main::opt_lib ne "") {
 
2626
    my $text = ParseTextSectionHeader($main::opt_lib);
 
2627
    if (defined($text)) {
 
2628
       my $start = $text->{vma};
 
2629
       my $finish = AddressAdd($start, $text->{size});
 
2630
 
 
2631
       push(@{$result}, [$main::opt_lib, $start, $finish, $start]);
 
2632
    }
 
2633
  }
 
2634
 
2281
2635
  # Append special entry for the main program
2282
2636
  my $max_pc = "0";
2283
2637
  foreach my $pc (keys(%{$pcs})) {
2487
2841
  # Ignore empty binaries
2488
2842
  if ($#{$pclist} < 0) { return; }
2489
2843
 
2490
 
  MapSymbolsWithNM($image, $offset, $pclist, $symbols);
 
2844
  my $got_symbols = MapSymbolsWithNM($image, $offset, $pclist, $symbols);
2491
2845
  if ($main::opt_interactive ||
 
2846
      $main::opt_addresses   ||
2492
2847
      $main::opt_lines       ||
2493
2848
      $main::opt_files       ||
2494
 
      $main::opt_list) {
 
2849
      $main::opt_list        ||
 
2850
      $main::opt_callgrind   ||
 
2851
      !$got_symbols) {
2495
2852
    GetLineNumbers($image, $offset, $pclist, $symbols);
2496
2853
  }
2497
2854
}
2540
2897
  close(SYMBOLS);
2541
2898
}
2542
2899
 
2543
 
# Use nm to map the list of referenced PCs to symbols
 
2900
# Use nm to map the list of referenced PCs to symbols.  Return true iff we
 
2901
# are able to read procedure information via nm.
2544
2902
sub MapSymbolsWithNM {
2545
2903
  my $image = shift;
2546
2904
  my $offset = shift;
2549
2907
 
2550
2908
  # Get nm output sorted by increasing address
2551
2909
  my $symbol_table = GetProcedureBoundaries($image, ".");
 
2910
  if (!%{$symbol_table}) {
 
2911
    return 0;
 
2912
  }
2552
2913
  # Start addresses are already the right length (8 or 16 hex digits).
2553
2914
  my @names = sort { $symbol_table->{$a}->[0] cmp $symbol_table->{$b}->[0] }
2554
2915
    keys(%{$symbol_table});
2559
2920
      my $pcstr = "0x" . $pc;
2560
2921
      $symbols->{$pc} = [$pcstr, "?", $pcstr];
2561
2922
    }
2562
 
    return;
 
2923
    return 0;
2563
2924
  }
2564
2925
 
2565
2926
  # Sort addresses so we can do a join against nm output
2574
2935
      $fullname = $names[$index];
2575
2936
      $name = ShortFunctionName($fullname);
2576
2937
    }
2577
 
    $symbols->{$pc} = [$name, "?", $fullname];
 
2938
    if ($mpc lt $symbol_table->{$fullname}->[1]) {
 
2939
      $symbols->{$pc} = [$name, "?", $fullname];
 
2940
    } else {
 
2941
      my $pcstr = "0x" . $pc;
 
2942
      $symbols->{$pc} = [$pcstr, "?", $pcstr];
 
2943
    }
2578
2944
  }
 
2945
  return 1;
2579
2946
}
2580
2947
 
2581
2948
sub ShortFunctionName {
2599
2966
  # Figure out the right default pathname prefix based on the program file
2600
2967
  # type:
2601
2968
  my $default_prefix = "/usr/bin/";
2602
 
  my $file_type = `/usr/bin/file $prog_file`;
2603
 
  if ($file_type =~ /ELF 32-bit/) {
2604
 
    $default_prefix = "/usr/bin/";
2605
 
  } elsif ($file_type =~ /ELF 64-bit/) {
 
2969
  # Follow symlinks (at least for systems where "file" supports that)
 
2970
  my $file_type = `/usr/bin/file -L $prog_file 2>/dev/null || /usr/bin/file $prog_file`;
 
2971
  if ($file_type !~ /executable/) {
 
2972
    warn "WARNING: program $prog_file is apparently not an executable\n";
 
2973
    # Don't change the default prefix.
 
2974
  } elsif ($file_type =~ /64-bit/) {
2606
2975
    # Change $address_length to 16 if the program file is ELF 64-bit.
2607
2976
    # We can't detect this from many (most?) heap or lock contention
2608
2977
    # profiles, since the actual addresses referenced are generally in low
2609
2978
    # memory even for 64-bit programs.
2610
2979
    $address_length = 16;
2611
 
  } else {
2612
 
    print STDERR "WARNING: program $prog_file is apparently not an ELF file\n";
2613
 
    # Don't change the default prefix.
2614
2980
  }
2615
2981
 
2616
2982
  # Go fill in %obj_tool_map with the pathnames to use:
2617
2983
  foreach my $tool (keys %obj_tool_map) {
2618
 
    $obj_tool_map{$tool} = ConfigureTool($tool, $default_prefix);
 
2984
    $obj_tool_map{$tool} = ConfigureTool($obj_tool_map{$tool},
 
2985
                                         $default_prefix);
2619
2986
  }
2620
2987
}
2621
2988
 
2641
3008
  if (-x $path) { return $path; }
2642
3009
 
2643
3010
  # Try the normal system default (/usr/bin/):
2644
 
  if ($prefix ne "/usr/bin") {
 
3011
  if ($prefix ne "/usr/bin/") {
2645
3012
    $path = "/usr/bin/$tool";
2646
3013
    if ($main::opt_debug) { print STDERR "  (c) Trying '$path'\n"; }
2647
3014
    if (-x $path) { return $path; }
2686
3053
}
2687
3054
 
2688
3055
 
2689
 
# Gets the procedure boundaries for all routines in "$image" whose names
2690
 
# match "$regexp" and returns them in a hashtable mapping from procedure
2691
 
# name to a two-element vector of [start address, end address]
2692
 
sub GetProcedureBoundaries {
2693
 
  my $image = shift;
 
3056
# Run $nm_command and get all the resulting procedure boundaries whose
 
3057
# names match "$regexp" and returns them in a hashtable mapping from
 
3058
# procedure name to a two-element vector of [start address, end address]
 
3059
sub GetProcedureBoundariesViaNm {
 
3060
  my $nm_command = shift;
2694
3061
  my $regexp = shift;
2695
3062
 
2696
3063
  my $symbol_table = {};
2697
 
  my $nm = $obj_tool_map{"nm"};
2698
 
  open(NM, "$nm -C -n $image |") || error("$nm: $!\n");
 
3064
  open(NM, "$nm_command |") || error("$nm_command: $!\n");
2699
3065
  my $last_start = "0";
2700
3066
  my $routine = "";
2701
3067
  while (<NM>) {
2703
3069
      my $start_val = $1;
2704
3070
      my $this_routine = $2;
2705
3071
      if (defined($routine) && $routine =~ m/$regexp/) {
2706
 
        $symbol_table->{$routine} = [$last_start, $start_val];
 
3072
        $symbol_table->{$routine} = [HexExtend($last_start),
 
3073
                                     HexExtend($start_val)];
2707
3074
      }
2708
3075
      $last_start = $start_val;
2709
3076
      $routine = $this_routine;
2714
3081
  return $symbol_table;
2715
3082
}
2716
3083
 
 
3084
# Gets the procedure boundaries for all routines in "$image" whose names
 
3085
# match "$regexp" and returns them in a hashtable mapping from procedure
 
3086
# name to a two-element vector of [start address, end address].
 
3087
# Will return an empty map if nm is not installed or not working properly.
 
3088
sub GetProcedureBoundaries {
 
3089
  my $image = shift;
 
3090
  my $regexp = shift;
 
3091
 
 
3092
  # For libc libraries, the copy in /usr/lib/debug contains debugging symbols
 
3093
  my $debugging = DebuggingLibrary($image);
 
3094
  if ($debugging) {
 
3095
    $image = $debugging;
 
3096
  }
 
3097
 
 
3098
  my $nm = $obj_tool_map{"nm"};
 
3099
  my $cppfilt = $obj_tool_map{"c++filt"};
 
3100
 
 
3101
  # nm can fail for two reasons: 1) $image isn't a debug library; 2) nm
 
3102
  # binary doesn't support --demangle.  For the first, we try with -D
 
3103
  # to at least get *exported* symbols.  For the second, we use c++filt
 
3104
  # instead of --demangle.  (c++filt is less reliable though, because it
 
3105
  # might interpret nm meta-data as c++ symbols and try to demangle it :-/)
 
3106
  foreach my $nm_command ("$nm -n --demangle $image 2>/dev/null",
 
3107
                          "$nm -n $image 2>&1 | $cppfilt",
 
3108
                          "$nm -D -n --demangle $image 2>/dev/null",
 
3109
                          "$nm -D -n $image 2>&1 | $cppfilt",
 
3110
                          "$nm -n $image 2>/dev/null",
 
3111
                          "$nm -D -n $image 2>/dev/null") {
 
3112
    my $symbol_table = GetProcedureBoundariesViaNm($nm_command, $regexp);
 
3113
    return $symbol_table if (%{$symbol_table});
 
3114
  }
 
3115
  my $symbol_table = {};
 
3116
  return $symbol_table;
 
3117
}
 
3118
 
2717
3119
 
2718
3120
# The test vectors for AddressAdd/Sub/Inc are 8-16-nibble hex strings.
2719
3121
# To make them more readable, we add underscores at interesting places.