| 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 | |
|---|
| 42 | use strict; |
|---|
| 43 | use File::Basename; |
|---|
| 44 | |
|---|
| 45 | my $memlog_fn = $ARGV[0]; |
|---|
| 46 | my $out_dir = $ARGV[1] || '.'; |
|---|
| 47 | |
|---|
| 48 | my $print_raw_proc_name = 0; |
|---|
| 49 | |
|---|
| 50 | if (! -f $memlog_fn) { |
|---|
| 51 | print "Usage: $0 <memlog file> [<output directory>]\n"; |
|---|
| 52 | exit 1; |
|---|
| 53 | } |
|---|
| 54 | |
|---|
| 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). |
|---|
| 59 | my $alcf_bu_dir = '/soft/compilers/bgclang/current/binutils/bin'; |
|---|
| 60 | if (-d $alcf_bu_dir) { |
|---|
| 61 | $ENV{'PATH'} = $alcf_bu_dir . ':' . $ENV{'PATH'}; |
|---|
| 62 | } |
|---|
| 63 | |
|---|
| 64 | open(MEMLOG, $memlog_fn) || die "Can't open $memlog_fn: $!"; |
|---|
| 65 | |
|---|
| 66 | # The first step is to determine the high-water mark. |
|---|
| 67 | my $max_rss = 0; |
|---|
| 68 | foreach 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 | |
|---|
| 81 | seek(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. |
|---|
| 85 | my $max_rss_time = 0; |
|---|
| 86 | my %malloc_lines; |
|---|
| 87 | foreach 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 | |
|---|
| 112 | close(MEMLOG); |
|---|
| 113 | |
|---|
| 114 | # Convert maxrss, currently in KB, to bytes. |
|---|
| 115 | $max_rss *= 1024; |
|---|
| 116 | |
|---|
| 117 | my $total_size = 0; |
|---|
| 118 | my %roots; |
|---|
| 119 | my %all_nodes; |
|---|
| 120 | foreach my $line (values %malloc_lines) { |
|---|
| 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+)/); |
|---|
| 132 | my ($time, $then_max_rss, $tid) = split(/\s+/, $state); |
|---|
| 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 | |
|---|
| 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 | } |
|---|
| 166 | |
|---|
| 167 | if (!exists $parent->{$pc}) { |
|---|
| 168 | $parent->{$pc} = $all_nodes{$pc}; |
|---|
| 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 | |
|---|
| 189 | my $txt_fn = "$out_dir/" . basename($memlog_fn) . ".txt"; |
|---|
| 190 | my $dot_fn = "$out_dir/" . basename($memlog_fn) . ".dot"; |
|---|
| 191 | my $ps_fn = "$out_dir/" . basename($memlog_fn) . ".ps"; |
|---|
| 192 | my $pdf_fn = "$out_dir/" . basename($memlog_fn) . ".pdf"; |
|---|
| 193 | |
|---|
| 194 | open(TXT, ">$txt_fn") || die "Can't open $txt_fn: $!"; |
|---|
| 195 | open(DOT, ">$dot_fn") || die "Can't open $dot_fn: $!"; |
|---|
| 196 | |
|---|
| 197 | sub 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 | |
|---|
| 207 | return sprintf("%.3f $sizes[$i]", $size); |
|---|
| 208 | } |
|---|
| 209 | |
|---|
| 210 | print DOT ("digraph \"memlog\" {\n"); |
|---|
| 211 | print DOT ("size=\"8,11\";\n"); |
|---|
| 212 | print DOT ("node [width=0.375,height=0.25];\n"); |
|---|
| 213 | |
|---|
| 214 | printf 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 | |
|---|
| 218 | printf 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 | |
|---|
| 221 | my %cached_names; |
|---|
| 222 | sub 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'}; |
|---|
| 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`; |
|---|
| 252 | chomp($func); |
|---|
| 253 | chomp($loc); |
|---|
| 254 | |
|---|
| 255 | if ($func !~ /^\?/) { |
|---|
| 256 | # In general, this function name might look something like: |
|---|
| 257 | # 00000329.plt_call.wcsnrtombs@@GLIBC_2.3+0 |
|---|
| 258 | $func =~ s/@.*//; # Remove trailing symbol version strings |
|---|
| 259 | $func =~ s/.*\.//; |
|---|
| 260 | $func = `c++filt '$func'`; |
|---|
| 261 | chomp($func); |
|---|
| 262 | |
|---|
| 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 | |
|---|
| 277 | $ret .= $func . '\n'; |
|---|
| 278 | |
|---|
| 279 | if ($loc !~ /^\?/) { |
|---|
| 280 | $ret .= $loc . '\n'; |
|---|
| 281 | } |
|---|
| 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'; |
|---|
| 288 | } |
|---|
| 289 | |
|---|
| 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'}; |
|---|
| 293 | } |
|---|
| 294 | |
|---|
| 295 | $cached_names{$pc} = $ret; |
|---|
| 296 | return $ret; |
|---|
| 297 | } |
|---|
| 298 | |
|---|
| 299 | my $skip_frac = 0.01; |
|---|
| 300 | my %skipped; |
|---|
| 301 | |
|---|
| 302 | foreach my $pc (keys %all_nodes) { |
|---|
| 303 | my $node = $all_nodes{$pc}; |
|---|
| 304 | |
|---|
| 305 | my $local_size = $node->{'size'}; |
|---|
| 306 | if ($local_size * 1.0 / $total_size < $skip_frac) { |
|---|
| 307 | $skipped{$pc} = 1; |
|---|
| 308 | next; |
|---|
| 309 | } |
|---|
| 310 | |
|---|
| 311 | my $fs = 8.0; |
|---|
| 312 | if ($local_size > 0) { |
|---|
| 313 | $fs = 50.0 * (abs($local_size * 1.0 / $total_size))**0.125; |
|---|
| 314 | } |
|---|
| 315 | |
|---|
| 316 | my $name = get_name($node); |
|---|
| 317 | |
|---|
| 318 | printf DOT ("N%s [label=\"%s\\n%s\", shape=box, fontsize=%.1f%s];\n", |
|---|
| 319 | $pc, $name, format_bytes($local_size), $fs); |
|---|
| 320 | } |
|---|
| 321 | |
|---|
| 322 | foreach my $pc (keys %all_nodes) { |
|---|
| 323 | if ($skipped{$pc}) { |
|---|
| 324 | next; |
|---|
| 325 | } |
|---|
| 326 | |
|---|
| 327 | my $node = $all_nodes{$pc}; |
|---|
| 328 | my $local_size = $node->{'size'}; |
|---|
| 329 | |
|---|
| 330 | foreach my $cpc (keys %{$node->{'child_sizes'}}) { |
|---|
| 331 | if ($skipped{$cpc}) { |
|---|
| 332 | next; |
|---|
| 333 | } |
|---|
| 334 | |
|---|
| 335 | my $child_size = $node->{'child_sizes'}->{$cpc}; |
|---|
| 336 | my $frac = $child_size * 1.0 / $local_size; |
|---|
| 337 | |
|---|
| 338 | my $weight = 100.0 * sqrt($frac); |
|---|
| 339 | my $style = sprintf("setlinewidth(%f)", 8.0 * sqrt($frac)); |
|---|
| 340 | |
|---|
| 341 | my $fs = 40.0 * $frac**0.125; |
|---|
| 342 | |
|---|
| 343 | printf DOT ("N%s -> N%s [label=\"%s\", weight=%d, style=\"%s\", fontsize=%.1f];\n", |
|---|
| 344 | $pc, $cpc, format_bytes($child_size), $weight, $style, $fs); |
|---|
| 345 | } |
|---|
| 346 | } |
|---|
| 347 | |
|---|
| 348 | print DOT ("}\n"); |
|---|
| 349 | |
|---|
| 350 | foreach 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 | |
|---|
| 394 | close(TXT); |
|---|
| 395 | close(DOT); |
|---|
| 396 | |
|---|
| 397 | system("dot -Tps2 < '$dot_fn' > '$ps_fn'"); |
|---|
| 398 | system("ps2pdf '$ps_fn' '$pdf_fn'"); |
|---|
| 399 | |
|---|
| 400 | exit 0; |
|---|
| 401 | |
|---|
![(please configure the [header_logo] section in trac.ini)](/projects/memlog/chrome/site/your_project_logo.png){kind=logo}
