source: memlog_analyze @ 9f07fa4

Revision 9f07fa4, 13.6 KB checked in by Hal Finkel <hfinkel@…>, 5 years ago (diff)

use ASCII quotes in license

  • Property mode set to 100755
Line 
1#! /usr/bin/env perl
2
3# *****************************************************************************
4#                   Copyright (C) 2015, UChicago Argonne, LLC
5#                              All Rights Reserved
6#                            memlog (ANL-SF-15-081)
7#                    Hal Finkel, Argonne National Laboratory
8#
9#                              OPEN SOURCE LICENSE
10#
11# Under the terms of Contract No. DE-AC02-06CH11357 with UChicago Argonne, LLC,
12# the U.S. Government retains certain rights in this software.
13#
14# Redistribution and use in source and binary forms, with or without
15# modification, are permitted provided that the following conditions are met:
16#
17# 1. Redistributions of source code must retain the above copyright notice, this
18#    list of conditions and the following disclaimer.
19#
20# 2. Redistributions in binary form must reproduce the above copyright notice,
21#    this list of conditions and the following disclaimer in the documentation
22#    and/or other materials provided with the distribution.
23#
24# 3. Neither the names of UChicago Argonne, LLC or the Department of Energy nor
25#    the names of its contributors may be used to endorse or promote products
26#    derived from this software without specific prior written permission.
27
28# *****************************************************************************
29#                                  DISCLAIMER
30#
31# THE SOFTWARE IS SUPPLIED "AS IS" WITHOUT WARRANTY OF ANY KIND.
32#
33# NEITHER THE UNTED STATES GOVERNMENT, NOR THE UNITED STATES DEPARTMENT OF
34# ENERGY, NOR UCHICAGO ARGONNE, LLC, NOR ANY OF THEIR EMPLOYEES, MAKES ANY
35# WARRANTY, EXPRESS OR IMPLIED, OR ASSUMES ANY LEGAL LIABILITY OR RESPONSIBILITY
36# FOR THE ACCURACY, COMPLETENESS, OR USEFULNESS OF ANY INFORMATION, DATA,
37# APPARATUS, PRODUCT, OR PROCESS DISCLOSED, OR REPRESENTS THAT ITS USE WOULD NOT
38# INFRINGE PRIVATELY OWNED RIGHTS.
39#
40# *****************************************************************************
41
42use strict;
43use File::Basename;
44use File::Path qw(make_path);
45use Getopt::Long;
46
47my $find_leaks = 0;
48my $print_raw_proc_name = 0;
49my $quiet = 0;
50my $help = 0;
51
52sub print_usage($) {
53  my $ec = $_[0];
54  my $usage = <<EOM;
55Usage: $0 [options] <memlog file or glob> [<output directory>]
56  options:
57    --leaks
58      Provide information on leaks instead of peak usage
59    --print-symbol-names
60      Include symbol names and offsets in the output
61    --quiet or -q
62      Don't print status messages while running
63EOM
64
65  print $usage;
66  exit($ec);
67}
68
69GetOptions("help|h|?" => \$help,
70           "leaks" => \$find_leaks,
71           "print-symbol-names" => \$print_raw_proc_name,
72           "quiet|q" => \$quiet)
73  or print_usage(1);
74
75if ($help) {
76  print_usage(0);
77}
78
79if (scalar(@ARGV) > 2) {
80  print_usage(2);
81}
82
83my $memlog_fn = $ARGV[0];
84my $out_dir = $ARGV[1] || '.';
85
86make_path($out_dir);
87
88if (! -f $memlog_fn) {
89  my @pot_fns = glob($memlog_fn);
90  if (scalar(@pot_fns)) {
91    if (!$quiet) {
92      print "Searching all files matching '$memlog_fn'\n";
93    }
94
95    my $pot_max_rss = 0;
96    my $pos_max_rss_fn;
97    foreach my $pot_fn (@pot_fns) {
98      my $last_line = `tail -n 1 '$pot_fn'`;
99      chomp($last_line);
100
101      my @parts = split(/\t/, $last_line);
102
103      my $op = shift(@parts);
104      my $state = shift(@parts);
105
106      my ($time, $then_max_rss, $tid, $then_arena, $then_mmap) =
107        split(/\s+/, $state);
108      if ($pot_max_rss < $then_max_rss) {
109        $pot_max_rss = $then_max_rss;
110        $pos_max_rss_fn = $pot_fn;
111      }
112    }
113
114    if (defined $pos_max_rss_fn) {
115      $memlog_fn = $pos_max_rss_fn;
116      goto have_memlog_fn;
117    }
118  }
119
120  print_usage(1);
121}
122have_memlog_fn:
123
124# The version of addr2line and friends that you use can make a big difference,
125# especially on BE ppc64, where older versions of addr2line did not account
126# correctly for the function descriptor setup. At ALCF, on the BG/Q, we have
127# newer versions not in the default search path (from bgclang).
128my $alcf_bu_dir = '/soft/compilers/bgclang/current/binutils/bin';
129if (-d $alcf_bu_dir) {
130  $ENV{'PATH'} = $alcf_bu_dir . ':' . $ENV{'PATH'};
131}
132
133open(MEMLOG, $memlog_fn) || die "Can't open $memlog_fn: $!";
134
135# The first step is to determine the high-water mark.
136my $max_rss = 0;
137my $arena = 0;
138my $mmap = 0;
139foreach my $line (<MEMLOG>) {
140  chomp($line);
141  my @parts = split(/\t/, $line);
142
143  my $op = shift(@parts);
144  my $state = shift(@parts);
145
146  my ($time, $then_max_rss, $tid, $then_arena, $then_mmap) =
147    split(/\s+/, $state);
148  if ($max_rss < $then_max_rss) {
149    $max_rss = $then_max_rss;
150    $arena = $then_arena;
151    $mmap = $then_mmap;
152  }
153}
154
155seek(MEMLOG, 0, 0);
156
157# Scan the log for malloc/free pairings. We're interested only in active
158# allocations at the time when the rss reaches the final maxrss.
159# If we're finding leaks, then go to the very end.
160my $active_alloc_time = 0;
161my %malloc_lines;
162foreach my $line (<MEMLOG>) {
163  chomp($line);
164  my @parts = split(/\t/, $line);
165
166  my $op = shift(@parts);
167  my $state = shift(@parts);
168
169  if ($op =~ /^M:/) {
170    my ($size, $ptr) = ($op =~ /^M: (\d+) 0x(\w+)/);
171    $malloc_lines{$ptr} = $line;
172  } elsif ($op =~ /^F:/) {
173    my ($ptr) = ($op =~ /^F: 0x(\w+)/);
174    delete $malloc_lines{$ptr};
175  } else {
176    next;
177  }
178
179  my ($time, $then_max_rss, $tid, $then_arena, $then_mmap) =
180    split(/\s+/, $state);
181  $active_alloc_time = $time;
182
183  if (!$find_leaks) {
184    # If we've reached the max rss, we've seen all we need to see.
185    if ($then_max_rss == $max_rss) {
186      last;
187    }
188  }
189}
190
191close(MEMLOG);
192
193# Convert maxrss, currently in KB, to bytes.
194$max_rss *= 1024;
195if (defined $arena) {
196  $arena *= 1024;
197}
198if (defined $mmap) {
199  $mmap *= 1024;
200}
201
202my $total_size = 0;
203my %roots;
204my %all_nodes;
205foreach my $line (values %malloc_lines) {
206  my @parts = split(/\t/, $line);
207
208  my $op = shift(@parts);
209  my $state = shift(@parts);
210
211  # Only dealing with allocations here...
212  if ($op !~ /^M:/) {
213    next;
214  }
215
216  my ($size, $ptr) = ($op =~ /^M: (\d+) 0x(\w+)/);
217  my ($time, $then_max_rss, $tid, $then_arena, $then_mmap) =
218    split(/\s+/, $state);
219
220  $total_size += $size;
221
222  sub level_parts($) {
223    my $level = @_[0];
224    my ($file_name, $proc_name, $off, $pc, $relpc) =
225      ($level =~ /^(.*) \((.*)\+0x(\w+)\) \[0x(\w+) \(0x(\w+)\)\]/);
226
227    return ($file_name, $proc_name, $off, $pc, $relpc);
228  }
229
230  # Put the top of the stack first.
231  @parts = reverse(@parts);
232
233  my $parent = \%roots;
234  for (my $i = 0; $i < scalar(@parts); ++$i) {
235    my $level = $parts[$i];
236    my ($file_name, $proc_name, $off, $pc, $relpc) = level_parts($level);
237
238    # Skip this level if we don't even know from what file it came.
239    if ($file_name eq '?') {
240      next;
241    }
242
243    # print STDERR "parsed: $file_name, $proc_name, $off, $pc, $relpc\n";
244
245    if (!exists $all_nodes{$pc}) {
246      $all_nodes{$pc}->{'file_name'} = $file_name;
247      $all_nodes{$pc}->{'proc_name'} = $proc_name;
248      $all_nodes{$pc}->{'off'} = $off;
249      $all_nodes{$pc}->{'pc'} = $pc;
250      $all_nodes{$pc}->{'relpc'} = $relpc;
251    }
252
253    if (!exists $parent->{$pc}) {
254      $parent->{$pc} = $all_nodes{$pc};
255    }
256
257    $parent->{$pc}->{'size'} += $size;
258
259    my ($next_file_name, $next_proc_name, $next_off, $next_pc, $next_relpc);
260    if ($i < scalar(@parts)-1) {
261     my $next_level = $parts[$i+1];
262     ($next_file_name, $next_proc_name, $next_off, $next_pc, $next_relpc) =
263       level_parts($next_level);
264      $parent->{$pc}->{'child_sizes'}->{$next_pc} += $size;
265    }
266
267    if (!exists $parent->{'children'}) {
268      $parent->{'children'} = {};
269    }
270
271    $parent = $parent->{'children'};
272  }
273}
274
275my $txt_fn = "$out_dir/" . basename($memlog_fn) . ".txt";
276my $dot_fn = "$out_dir/" . basename($memlog_fn) . ".dot";
277my $ps_fn = "$out_dir/" . basename($memlog_fn) . ".ps";
278my $pdf_fn = "$out_dir/" . basename($memlog_fn) . ".pdf";
279
280if (!$quiet) {
281  print "Creating $txt_fn\n";
282}
283
284open(TXT, ">$txt_fn") || die "Can't open $txt_fn: $!";
285
286if (!$quiet) {
287  print "Creating $dot_fn\n";
288}
289
290open(DOT, ">$dot_fn") || die "Can't open $dot_fn: $!";
291
292sub format_bytes($) {
293  my @sizes = qw( B KB MB GB TB PB );
294  my $size = $_[0];
295
296  my $i = 0;
297  while ($size > 1024) {
298    $size /= 1024;
299    ++$i;
300  }
301
302  return sprintf("%.3f $sizes[$i]", $size);
303}
304
305sub format_bytes_or_unk($) {
306  my $b = $_[0];
307  return defined($b) ? format_bytes($b) : "(unknown)";
308}
309
310print DOT ("digraph \"memlog\" {\n");
311print DOT ("size=\"8,11\";\n");
312print DOT ("node [width=0.375,height=0.25];\n");
313
314my $find_type = $find_leaks ? " (leaks)" : "";
315print DOT "subgraph cluster_key {\n";
316print DOT "\trank=min;\n";
317print DOT "\tlabel=\"memlog\";\n";
318print DOT "\tfontsize=100;\n";
319print DOT "\trankdir=UR;\n";
320printf DOT ("Legend [shape=box, fontsize=100, shape=plaintext," .
321            "label=\"Total: %s active$find_type at maxrss = %s after %s s\\narena: %s\\nmmap: %s\"];\n",
322            format_bytes($total_size), format_bytes($max_rss),
323            $active_alloc_time, format_bytes_or_unk($arena),
324            format_bytes_or_unk($mmap));
325print DOT "}\n";
326
327printf TXT ("memlog: Total: %s active$find_type at maxrss = %s after %s s\n\tarena: %s\tmmap: %s\n\n",
328            format_bytes($total_size), format_bytes($max_rss),
329            $active_alloc_time, format_bytes_or_unk($arena),
330            format_bytes_or_unk($mmap));
331
332my %cached_names;
333sub get_name($) {
334  my $node = $_[0];
335  my $pc = $node->{'pc'};
336
337  if (exists $cached_names{$pc}) {
338    return $cached_names{$pc};
339  }
340
341  my $ret = '';
342
343  # Prefer the relative offset (that is what we want for shared libraries), but
344  # if is not available, use the full offset (which is what we want for the
345  # base executable).
346  my $exe_off = $node->{'relpc'};
347  if (!$exe_off) {
348    $exe_off = $pc;
349  }
350
351  my $file_name = $node->{'file_name'};
352
353  # If we don't have an absolute path, this is probably the base dynamic
354  # executable, so ask the shell which one it used (not foolproof because we
355  # might not have the same PATH now, but hopefully is generally the right
356  # thing).
357  if ($file_name !~ /^\//) {
358    $file_name = `which '$file_name'`;
359    chomp($file_name);
360  }
361
362  my ($func, $loc) = `addr2line -e '$file_name' -f 0x$exe_off`;
363  chomp($func);
364  chomp($loc);
365
366  if ($func !~ /^\?/) {
367    # In general, this function name might look something like:
368    #   00000329.plt_call.wcsnrtombs@@GLIBC_2.3+0
369    $func =~ s/@.*//; # Remove trailing symbol version strings
370    $func =~ s/.*\.//;
371    $func = `c++filt '$func'`;
372    chomp($func);
373
374    # It sometimes happens that addr2line is a bit too smart: when debugging
375    # information is available, it might print a local alias for the
376    # function instead of the full name (for example, printing 'List'
377    # instead of 'Foo::List<int>::List(int, int const&)').
378    if ($node->{'proc_name'} ne '?') {
379      my $proc_name = $node->{'proc_name'};
380      $proc_name = `c++filt '$proc_name'`;
381      chomp($proc_name);
382
383      if (length($proc_name) > length($func)) {
384        $func = $proc_name;
385      }
386    }
387
388    $ret .= $func . '\n';
389
390    if ($loc !~ /^[:?]/) {
391      $ret .= $loc . '\n';
392    }
393  } elsif ($node->{'proc_name'} ne '?') {
394    my $proc_name = $node->{'proc_name'};
395    $proc_name = `c++filt '$proc_name'`;
396    chomp($proc_name);
397
398    $ret .= $proc_name . '\n';
399  }
400
401  $ret .= $node->{'file_name'};
402  if ($print_raw_proc_name and $node->{'proc_name'} ne '?') {
403    $ret .= '\n' . $node->{'proc_name'} . '+0x' . $node->{'off'};
404  }
405
406  $cached_names{$pc} = $ret;
407  return $ret;
408}
409
410my $skip_frac = 0.01;
411my %skipped;
412
413foreach my $pc (keys %all_nodes) {
414  my $node = $all_nodes{$pc};
415
416  my $local_size = $node->{'size'};
417  if ($local_size * 1.0 / $total_size < $skip_frac) {
418    $skipped{$pc} = 1;
419    next;
420  }
421
422  my $fs = 8.0;
423  if ($local_size > 0) {
424    $fs = 50.0 * (abs($local_size * 1.0 / $total_size))**0.125;
425  }
426
427  my $name = get_name($node);
428
429  printf DOT ("N%s [label=\"%s\\n%s\", shape=box, fontsize=%.1f%s];\n",
430    $pc, $name, format_bytes($local_size), $fs);
431}
432
433foreach my $pc (keys %all_nodes) {
434  if ($skipped{$pc}) {
435    next;
436  }
437
438  my $node = $all_nodes{$pc};
439  my $local_size = $node->{'size'};
440
441  foreach my $cpc (keys %{$node->{'child_sizes'}}) {
442    if ($skipped{$cpc}) {
443      next;
444    }
445
446    my $child_size = $node->{'child_sizes'}->{$cpc};
447    my $frac = $child_size * 1.0 / $local_size;
448
449    my $weight = 100.0 * sqrt($frac);
450    my $style = sprintf("setlinewidth(%f)", 8.0 * sqrt($frac));
451
452    my $fs = 40.0 * $frac**0.125;
453
454    printf DOT ("N%s -> N%s [label=\"%s\", weight=%d, style=\"%s\", fontsize=%.1f];\n",
455      $pc, $cpc, format_bytes($child_size), $weight, $style, $fs);
456  }
457}
458
459print DOT ("}\n");
460
461foreach my $pc (sort { $all_nodes{$::b}->{'size'} <=>
462                       $all_nodes{$::a}->{'size'} } keys %all_nodes) {
463  if ($skipped{$pc}) {
464    next;
465  }
466
467  print TXT ('*' x 80) . "\n\n";
468
469  my $node = $all_nodes{$pc};
470
471  my $local_size = $node->{'size'};
472  printf TXT ("%s - %.1f%%\n", format_bytes($local_size),
473              $local_size * 100.0 / $total_size);
474
475  my $name = get_name($node);
476  $name =~ s/\\n/\n/g;
477
478  print TXT "$name\n$pc\n";
479
480  print TXT "\nMEMORY ALLOCATED BY CALLEES:\n";
481
482  foreach my $cpc (sort { $node->{'child_sizes'}->{$::b} <=>
483                          $node->{'child_sizes'}->{$::a} }
484                     keys %{$node->{'child_sizes'}}) {
485    if ($skipped{$cpc}) {
486      next;
487    }
488
489    my $child_node = $all_nodes{$cpc};
490    my $child_size = $node->{'child_sizes'}->{$cpc};
491
492    printf TXT ("\t%s - %.1f%%\n", format_bytes($child_size),
493                $child_size * 100.0 / $local_size);
494
495    my $child_name = get_name($child_node);
496    $child_name =~ s/\\n/\n\t/g;
497    print TXT "\t$child_name\n\t$cpc\n";
498
499    print TXT "\n";
500  }
501
502  print TXT "\n";
503}
504
505close(TXT);
506close(DOT);
507
508if (!$quiet) {
509  print "Creating $ps_fn\n";
510}
511
512system("dot -Tps2 < '$dot_fn' > '$ps_fn'");
513
514if (!$quiet) {
515  print "Creating $pdf_fn\n";
516}
517
518system("ps2pdf '$ps_fn' '$pdf_fn'");
519
520exit 0;
521
Note: See TracBrowser for help on using the repository browser.