source: memlog2dot @ 09f3093

Revision 09f3093, 11.1 KB checked in by Hal Finkel <hfinkel@…>, 9 years ago (diff)

Add open-source license

  • Property mode set to 100755
RevLine 
[ebd57f8]1#! /usr/bin/env perl
[09f3093]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
[ebd57f8]42use strict;
43use File::Basename;
44
[81dea5b]45my $memlog_fn = $ARGV[0];
46my $out_dir = $ARGV[1] || '.';
47
[6bfe6a1]48my $print_raw_proc_name = 0;
49
[81dea5b]50if (! -f $memlog_fn) {
51  print "Usage: $0 <memlog file> [<output directory>]\n";
52  exit 1;
53}
54
[747d2b1]55# The version of addr2line and friends that you use can make a big difference,
56# especially on BE ppc64, where older versions of addr2line did not account
57# correctly for the function descriptor setup. At ALCF, on the BG/Q, we have
58# newer versions not in the default search path (from bgclang).
59my $alcf_bu_dir = '/soft/compilers/bgclang/current/binutils/bin';
60if (-d $alcf_bu_dir) {
61  $ENV{'PATH'} = $alcf_bu_dir . ':' . $ENV{'PATH'};
62}
63
[81dea5b]64open(MEMLOG, $memlog_fn) || die "Can't open $memlog_fn: $!";
65
[0edbc98]66# The first step is to determine the high-water mark.
67my $max_rss = 0;
68foreach my $line (<MEMLOG>) {
69  chomp($line);
70  my @parts = split(/\t/, $line);
71
72  my $op = shift(@parts);
73  my $state = shift(@parts);
74
75  my ($time, $then_max_rss, $tid) = split(/\s+/, $state);
76  if ($max_rss < $then_max_rss) {
77    $max_rss = $then_max_rss;
78  }
79}
80
81seek(MEMLOG, 0, 0);
82
83# Scan the log for malloc/free pairings. We're interested only in active
84# allocations at the time when the rss reaches the final maxrss.
85my $max_rss_time = 0;
86my %malloc_lines;
87foreach my $line (<MEMLOG>) {
88  chomp($line);
89  my @parts = split(/\t/, $line);
90
91  my $op = shift(@parts);
92  my $state = shift(@parts);
93
94  if ($op =~ /^M:/) {
95    my ($size, $ptr) = ($op =~ /^M: (\d+) 0x(\w+)/);
96    $malloc_lines{$ptr} = $line;
97  } elsif ($op =~ /^F:/) {
98    my ($ptr) = ($op =~ /^F: 0x(\w+)/);
99    delete $malloc_lines{$ptr};
100  } else {
101    next;
102  }
103
104  # If we've reached the max rss, we've seen all we need to see.
105  my ($time, $then_max_rss, $tid) = split(/\s+/, $state);
106  $max_rss_time = $time;
107  if ($then_max_rss == $max_rss) {
108    last;
109  }
110}
111
112close(MEMLOG);
113
114# Convert maxrss, currently in KB, to bytes.
115$max_rss *= 1024;
116
[ebd57f8]117my $total_size = 0;
118my %roots;
[c4f89cf]119my %all_nodes;
[0edbc98]120foreach my $line (values %malloc_lines) {
[ebd57f8]121  my @parts = split(/\t/, $line);
122
123  my $op = shift(@parts);
124  my $state = shift(@parts);
125
126  # Only dealing with allocations here...
127  if ($op !~ /^M:/) {
128    next;
129  }
130
131  my ($size, $ptr) = ($op =~ /^M: (\d+) 0x(\w+)/);
[0edbc98]132  my ($time, $then_max_rss, $tid) = split(/\s+/, $state);
[ebd57f8]133
134  $total_size += $size;
135
136  sub level_parts($) {
137    my $level = @_[0];
138    my ($file_name, $proc_name, $off, $pc, $relpc) =
139      ($level =~ /^(.*) \((.*)\+0x(\w+)\) \[0x(\w+) \(0x(\w+)\)\]/);
140
141    return ($file_name, $proc_name, $off, $pc, $relpc);
142  }
143
144  # Put the top of the stack first.
145  @parts = reverse(@parts);
146
147  my $parent = \%roots;
148  for (my $i = 0; $i < scalar(@parts); ++$i) {
149    my $level = $parts[$i];
150    my ($file_name, $proc_name, $off, $pc, $relpc) = level_parts($level);
151
152    # Skip this level if we don't even know from what file it came.
153    if ($file_name eq '?') {
154      next;
155    }
156
157    # print STDERR "parsed: $file_name, $proc_name, $off, $pc, $relpc\n";
158
[c4f89cf]159    if (!exists $all_nodes{$pc}) {
160      $all_nodes{$pc}->{'file_name'} = $file_name;
161      $all_nodes{$pc}->{'proc_name'} = $proc_name;
162      $all_nodes{$pc}->{'off'} = $off;
163      $all_nodes{$pc}->{'pc'} = $pc;
164      $all_nodes{$pc}->{'relpc'} = $relpc;
165    }
[ebd57f8]166
[c4f89cf]167    if (!exists $parent->{$pc}) {
168      $parent->{$pc} = $all_nodes{$pc};
[ebd57f8]169    }
170
171    $parent->{$pc}->{'size'} += $size;
172
173    my ($next_file_name, $next_proc_name, $next_off, $next_pc, $next_relpc);
174    if ($i < scalar(@parts)-1) {
175     my $next_level = $parts[$i+1];
176     ($next_file_name, $next_proc_name, $next_off, $next_pc, $next_relpc) =
177       level_parts($next_level);
178      $parent->{$pc}->{'child_sizes'}->{$next_pc} += $size;
179    }
180
181    if (!exists $parent->{'children'}) {
182      $parent->{'children'} = {};
183    }
184
185    $parent = $parent->{'children'};
186  }
187}
188
[20b45de]189my $txt_fn = "$out_dir/" . basename($memlog_fn) . ".txt";
[81dea5b]190my $dot_fn = "$out_dir/" . basename($memlog_fn) . ".dot";
191my $ps_fn = "$out_dir/" . basename($memlog_fn) . ".ps";
192my $pdf_fn = "$out_dir/" . basename($memlog_fn) . ".pdf";
193
[20b45de]194open(TXT, ">$txt_fn") || die "Can't open $txt_fn: $!";
[81dea5b]195open(DOT, ">$dot_fn") || die "Can't open $dot_fn: $!";
196
[ebd57f8]197sub format_bytes($) {
198  my @sizes = qw( B KB MB GB TB PB );
199  my $size = $_[0];
200
201  my $i = 0;
202  while ($size > 1024) {
203    $size /= 1024;
204    ++$i;
205  }
206
[4bd7a88]207  return sprintf("%.3f $sizes[$i]", $size);
[ebd57f8]208}
209
[bdaf020]210print DOT ("digraph \"memlog\" {\n");
[81dea5b]211print DOT ("size=\"8,11\";\n");
212print DOT ("node [width=0.375,height=0.25];\n");
[ebd57f8]213
[bdaf020]214printf DOT ("Legend [shape=box, fontsize=100, shape=oval," .
215            "label=\"Total: %s active at maxrss = %s after %s s\"];\n",
216            format_bytes($total_size), format_bytes($max_rss), $max_rss_time);
217
[20b45de]218printf TXT ("memlog: Total: %s active at maxrss = %s after %s s\n\n",
219            format_bytes($total_size), format_bytes($max_rss), $max_rss_time);
220
[ebd57f8]221my %cached_names;
222sub get_name($) {
223  my $node = $_[0];
224  my $pc = $node->{'pc'};
225
226  if (exists $cached_names{$pc}) {
227    return $cached_names{$pc};
228  }
229
230  my $ret = '';
231
232  # Prefer the relative offset (that is what we want for shared libraries), but
233  # if is not available, use the full offset (which is what we want for the
234  # base executable).
235  my $exe_off = $node->{'relpc'};
236  if (!$exe_off) {
237    $exe_off = $pc;
238  }
239
240  my $file_name = $node->{'file_name'};
[518793d]241
242  # If we don't have an absolute path, this is probably the base dynamic
243  # executable, so ask the shell which one it used (not foolproof because we
244  # might not have the same PATH now, but hopefully is generally the right
245  # thing).
246  if ($file_name !~ /^\//) {
247    $file_name = `which '$file_name'`;
248    chomp($file_name);
249  }
250
251  my ($func, $loc) = `addr2line -e '$file_name' -f 0x$exe_off`;
[ebd57f8]252  chomp($func);
253  chomp($loc);
254
255  if ($func !~ /^\?/) {
[6520ef5]256    # In general, this function name might look something like:
257    #   00000329.plt_call.wcsnrtombs@@GLIBC_2.3+0
[10599da]258    $func =~ s/@.*//; # Remove trailing symbol version strings
[ebd57f8]259    $func =~ s/.*\.//;
260    $func = `c++filt '$func'`;
261    chomp($func);
262
[1bd82e0]263    # It sometimes happens that addr2line is a bit too smart: when debugging
264    # information is available, it might print a local alias for the
265    # function instead of the full name (for example, printing 'List'
266    # instead of 'Foo::List<int>::List(int, int const&)').
267    if ($node->{'proc_name'} ne '?') {
268      my $proc_name = $node->{'proc_name'};
269      $proc_name = `c++filt '$proc_name'`;
270      chomp($proc_name);
271
272      if (length($proc_name) > length($func)) {
273        $func = $proc_name;
274      }
275    }
276
[081a0fa]277    $ret .= $func . '\n';
278
279    if ($loc !~ /^\?/) {
280      $ret .= $loc . '\n';
281    }
[4bd7a88]282  } elsif ($node->{'proc_name'} ne '?') {
283    my $proc_name = $node->{'proc_name'};
284    $proc_name = `c++filt '$proc_name'`;
285    chomp($proc_name);
286
287    $ret .= $proc_name . '\n';
[ebd57f8]288  }
289
[6bfe6a1]290  $ret .= $node->{'file_name'};
291  if ($print_raw_proc_name and $node->{'proc_name'} ne '?') {
292    $ret .= '\n' . $node->{'proc_name'} . '+0x' . $node->{'off'};
[ebd57f8]293  }
294
295  $cached_names{$pc} = $ret;
296  return $ret;
297}
298
[4bd7a88]299my $skip_frac = 0.01;
300my %skipped;
301
[c4f89cf]302foreach my $pc (keys %all_nodes) {
303  my $node = $all_nodes{$pc};
[ebd57f8]304
305  my $local_size = $node->{'size'};
[4bd7a88]306  if ($local_size * 1.0 / $total_size < $skip_frac) {
[c4f89cf]307    $skipped{$pc} = 1;
[4bd7a88]308    next;
309  }
[ebd57f8]310
311  my $fs = 8.0;
312  if ($local_size > 0) {
[4bd7a88]313    $fs = 50.0 * (abs($local_size * 1.0 / $total_size))**0.125;
[ebd57f8]314  }
315
[20b45de]316  my $name = get_name($node);
317
[81dea5b]318  printf DOT ("N%s [label=\"%s\\n%s\", shape=box, fontsize=%.1f%s];\n",
[c4f89cf]319    $pc, $name, format_bytes($local_size), $fs);
[ebd57f8]320}
321
[c4f89cf]322foreach my $pc (keys %all_nodes) {
323  if ($skipped{$pc}) {
[4bd7a88]324    next;
325  }
[ebd57f8]326
[20b45de]327  my $node = $all_nodes{$pc};
328  my $local_size = $node->{'size'};
329
[ebd57f8]330  foreach my $cpc (keys %{$node->{'child_sizes'}}) {
[4bd7a88]331    if ($skipped{$cpc}) {
332      next;
333    }
334
[ebd57f8]335    my $child_size = $node->{'child_sizes'}->{$cpc};
336    my $frac = $child_size * 1.0 / $local_size;
337
[4bd7a88]338    my $weight = 100.0 * sqrt($frac);
[6520ef5]339    my $style = sprintf("setlinewidth(%f)", 8.0 * sqrt($frac));
[ebd57f8]340
[6520ef5]341    my $fs = 40.0 * $frac**0.125;
342
[81dea5b]343    printf DOT ("N%s -> N%s [label=\"%s\", weight=%d, style=\"%s\", fontsize=%.1f];\n",
[6520ef5]344      $pc, $cpc, format_bytes($child_size), $weight, $style, $fs);
[ebd57f8]345  }
346}
347
[81dea5b]348print DOT ("}\n");
349
[20b45de]350foreach my $pc (sort { $all_nodes{$::b}->{'size'} <=>
351                       $all_nodes{$::a}->{'size'} } keys %all_nodes) {
352  if ($skipped{$pc}) {
353    next;
354  }
355
356  print TXT ('*' x 80) . "\n\n";
357
358  my $node = $all_nodes{$pc};
359
360  my $local_size = $node->{'size'};
361  printf TXT ("%s - %.1f%%\n", format_bytes($local_size),
362              $local_size * 100.0 / $total_size);
363
364  my $name = get_name($node);
365  $name =~ s/\\n/\n/g;
366
367  print TXT "$name\n$pc\n";
368
369  print TXT "\nMEMORY ALLOCATED BY CALLEES:\n";
370
371  foreach my $cpc (sort { $node->{'child_sizes'}->{$::b} <=>
372                          $node->{'child_sizes'}->{$::a} }
373                     keys %{$node->{'child_sizes'}}) {
374    if ($skipped{$cpc}) {
375      next;
376    }
377
378    my $child_node = $all_nodes{$cpc};
379    my $child_size = $node->{'child_sizes'}->{$cpc};
380
381    printf TXT ("\t%s - %.1f%%\n", format_bytes($child_size),
382                $child_size * 100.0 / $local_size);
383
384    my $child_name = get_name($child_node);
385    $child_name =~ s/\\n/\n\t/g;
386    print TXT "\t$child_name\n\t$cpc\n";
387
388    print TXT "\n";
389  }
390
391  print TXT "\n";
392}
393
394close(TXT);
[81dea5b]395close(DOT);
396
397system("dot -Tps2 < '$dot_fn' > '$ps_fn'");
398system("ps2pdf '$ps_fn' '$pdf_fn'");
399
400exit 0;
[ebd57f8]401
Note: See TracBrowser for help on using the repository browser.