callgrind/callgrind_control.in

   1 #! /usr/bin/perl -w
   2 ##--------------------------------------------------------------------##
   3 ##--- Control supervision of applications run with callgrind       ---##
   4 ##---                                            callgrind_control ---##
   5 ##--------------------------------------------------------------------##
   6
   7 #  This file is part of Callgrind, a cache-simulator and call graph
   8 #  tracer built on Valgrind.
   9 #
  10 #  Copyright (C) 2003-2017 Josef Weidendorfer <Josef.Weidendorfer@gmx.de>
  11 #
  12 #  This program is free software; you can redistribute it and/or
  13 #  modify it under the terms of the GNU General Public License as
  14 #  published by the Free Software Foundation; either version 2 of the
  15 #  License, or (at your option) any later version.
  16 #
  17 #  This program is distributed in the hope that it will be useful, but
  18 #  WITHOUT ANY WARRANTY; without even the implied warranty of
  19 #  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  20 #  General Public License for more details.
  21 #
  22 #  You should have received a copy of the GNU General Public License
  23 #  along with this program; if not, write to the Free Software
  24 #  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA
  25 #  02111-1307, USA.
  26 use File::Basename;
  27
  28 # vgdb_exe will be set to a vgdb found 'near' the callgrind_control file
  29 my $vgdb_exe = "";
  30
  31 sub getCallgrindPids {
  32
  33   @pids = ();
  34   open LIST, $vgdb_exe . " $vgdbPrefixOption -l|";
  35   while(<LIST>) {
  36       if (/^use --pid=(\d+) for \S*?valgrind\s+(.*?)\s*$/) {
  37           $pid = $1;
  38           $cmd = $2;
  39           if (!($cmd =~ /--tool=callgrind/)) { next; }
  40           while($cmd =~ s/^-+\S+\s+//) {}
  41           $cmdline{$pid} = $cmd;
  42           $cmd =~ s/^(\S*).*/$1/;
  43           $cmd{$pid} = $cmd;
  44           #print "Found PID $pid, cmd '$cmd{$pid}', cmdline '$cmdline{$pid}'.\n";
  45           push(@pids, $pid);
  46       }
  47   }
  48   close LIST;
  49 }
  50
  51 sub printHeader {
  52   if ($headerPrinted) { return; }
  53   $headerPrinted = 1;
  54
  55   print "Observe the status and control currently active callgrind runs.\n";
  56   print "(C) 2003-2011, Josef Weidendorfer (Josef.Weidendorfer\@gmx.de)\n\n";
  57 }
  58
  59 sub printVersion {
  60   print "callgrind_control-@VERSION@\n";
  61   exit;
  62 }
  63
  64 sub shortHelp {
  65   print "See '$0 -h' for help.\n";
  66   exit;
  67 }
  68
  69 sub printHelp {
  70   printHeader;
  71
  72   print "Usage: callgrind_control [options] [pid|program-name...]\n\n";
  73   print "If no pids/names are given, an action is applied to all currently\n";
  74   print "active Callgrind runs. Default action is printing short information.\n\n";
  75   print "Options:\n";
  76   print "  -h --help         Show this help text\n";
  77   print "  --version         Show version\n";
  78   print "  -s --stat         Show statistics\n";
  79   print "  -b --back         Show stack/back trace\n";
  80   print "  -e [<A>,...]      Show event counters for <A>,... (default: all)\n";
  81   print "  --dump[=<s>]      Request a dump optionally using <s> as description\n";
  82   print "  -z --zero         Zero all event counters\n";
  83   print "  -k --kill         Kill\n";
  84   print "  -i --instr=on|off Switch instrumentation state on/off\n";
  85   print "Uncommon options:\n";
  86   print "  --vgdb-prefix=<prefix> Only provide this if the same was given to Valgrind\n";
  87   print "\n";
  88   exit;
  89 }
  90
  91
  92 #
  93 # Parts more or less copied from cg_annotate (author: Nicholas Nethercote)
  94 #
  95
  96 sub prepareEvents {
  97
  98   @events = split(/\s+/, $events);
  99   %events = ();
 100   $n = 0;
 101   foreach $event (@events) {
 102     $events{$event} = $n;
 103     $n++;
 104   }
 105   if (@show_events) {
 106     foreach my $show_event (@show_events) {
 107       (defined $events{$show_event}) or
 108         print "Warning: Event `$show_event' is not being collected\n";
 109     }
 110   } else {
 111     @show_events = @events;
 112   }
 113   @show_order = ();
 114   foreach my $show_event (@show_events) {
 115     push(@show_order, $events{$show_event});
 116   }
 117 }
 118
 119 sub max ($$)
 120 {
 121     my ($x, $y) = @_;
 122     return ($x > $y ? $x : $y);
 123 }
 124
 125 sub line_to_CC ($)
 126 {
 127     my @CC = (split /\s+/, $_[0]);
 128     (@CC <= @events) or die("Line $.: too many event counts\n");
 129     return \@CC;
 130 }
 131
 132 sub commify ($) {
 133     my ($val) = @_;
 134     1 while ($val =~ s/^(\d+)(\d{3})/$1,$2/);
 135     return $val;
 136 }
 137
 138 sub compute_CC_col_widths (@)
 139 {
 140     my @CCs = @_;
 141     my $CC_col_widths = [];
 142
 143     # Initialise with minimum widths (from event names)
 144     foreach my $event (@events) {
 145         push(@$CC_col_widths, length($event));
 146     }
 147
 148     # Find maximum width count for each column.  @CC_col_width positions
 149     # correspond to @CC positions.
 150     foreach my $CC (@CCs) {
 151         foreach my $i (0 .. scalar(@$CC)-1) {
 152             if (defined $CC->[$i]) {
 153                 # Find length, accounting for commas that will be added
 154                 my $length = length $CC->[$i];
 155                 my $clength = $length + int(($length - 1) / 3);
 156                 $CC_col_widths->[$i] = max($CC_col_widths->[$i], $clength);
 157             }
 158         }
 159     }
 160     return $CC_col_widths;
 161 }
 162
 163 # Print the CC with each column's size dictated by $CC_col_widths.
 164 sub print_CC ($$)
 165 {
 166     my ($CC, $CC_col_widths) = @_;
 167
 168     foreach my $i (@show_order) {
 169         my $count = (defined $CC->[$i] ? commify($CC->[$i]) : ".");
 170         my $space = ' ' x ($CC_col_widths->[$i] - length($count));
 171         print("$space$count ");
 172     }
 173 }
 174
 175 sub print_events ($)
 176 {
 177     my ($CC_col_widths) = @_;
 178
 179     foreach my $i (@show_order) {
 180         my $event       = $events[$i];
 181         my $event_width = length($event);
 182         my $col_width   = $CC_col_widths->[$i];
 183         my $space       = ' ' x ($col_width - $event_width);
 184         print("$space$event ");
 185     }
 186 }
 187
 188
 189
 190 #
 191 # Main
 192 #
 193
 194 # Search the appropriate vgdb executable
 195 my $controldir = dirname(__FILE__);
 196 if (-x $controldir . "/vgdb") {
 197     # classical case: callgrind_control and vgdb from the install bin dir
 198     $vgdb_exe = $controldir . "/vgdb";
 199 } elsif (-x $controldir . "/../coregrind/vgdb") {
 200     # callgrind_control called from the callgrind tool source/build dir
 201     $vgdb_exe = $controldir . "/../coregrind/vgdb";
 202 } else {
 203     # no idea. Use whatever vgdb found in PATH
 204     $vgdb_exe = "vgdb"
 205 }
 206 # print "will use vgdb at [" . $vgdb_exe . "]\n";
 207
 208 # To find the list of active pids, we need to have
 209 # the --vgdb-prefix option if given.
 210 $vgdbPrefixOption = "";
 211 foreach $arg (@ARGV) {
 212     if ($arg =~ /^--vgdb-prefix=.*$/) {
 213         $vgdbPrefixOption=$arg;
 214     }
 215     next;
 216 }
 217
 218 getCallgrindPids;
 219
 220 $requestEvents = 0;
 221 $requestDump = 0;
 222 $switchInstr = 0;
 223 $headerPrinted = 0;
 224 $dumpHint = "";
 225
 226 $verbose = 0;
 227
 228 %spids = ();
 229 foreach $arg (@ARGV) {
 230   if ($arg =~ /^-/) {
 231     if ($requestDump == 1) { $requestDump = 2; }
 232     if ($requestEvents == 1) { $requestEvents = 2; }
 233
 234     if ($arg =~ /^(-h|--help)$/) {
 235         printHelp;
 236     }
 237     elsif ($arg =~ /^--version$/) {
 238         printVersion;
 239     }
 240     elsif ($arg =~ /^--vgdb-prefix=.*$/) {
 241         # handled during the initial parsing.
 242         next;
 243     }
 244     elsif ($arg =~ /^-v$/) {
 245         $verbose++;
 246         next;
 247     }
 248     elsif ($arg =~ /^(-s|--stat)$/) {
 249         $printStatus = 1;
 250         next;
 251     }
 252     elsif ($arg =~ /^(-b|--back)$/) {
 253         $printBacktrace = 1;
 254         next;
 255     }
 256     elsif ($arg =~ /^-e$/) {
 257         $requestEvents = 1;
 258         next;
 259     }
 260     elsif ($arg =~ /^(-d|--dump)(|=.*)$/) {
 261         if ($2 ne "") {
 262             $requestDump = 2;
 263             $dumpHint = substr($2,1);
 264         }
 265         else {
 266             # take next argument as dump hint
 267             $requestDump = 1;
 268         }
 269         next;
 270     }
 271     elsif ($arg =~ /^(-z|--zero)$/) {
 272         $requestZero = 1;
 273         next;
 274     }
 275     elsif ($arg =~ /^(-k|--kill)$/) {
 276         $requestKill = 1;
 277         next;
 278     }
 279     elsif ($arg =~ /^(-i|--instr)(|=on|=off)$/) {
 280         $switchInstr = 2;
 281         if ($2 eq "=on") {
 282             $switchInstrMode = "on";
 283         }
 284         elsif ($2 eq "=off") {
 285             $switchInstrMode = "off";
 286         }
 287         else {
 288             # check next argument for "on" or "off"
 289             $switchInstr = 1;
 290         }
 291         next;
 292     }
 293     else {
 294         print "Error: unknown command line option '$arg'.\n";
 295         shortHelp;
 296     }
 297   }
 298
 299   if ($arg =~ /^[A-Za-z_]/) {
 300     # arguments of -d/-e/-i are non-numeric
 301     if ($requestDump == 1) {
 302       $requestDump = 2;
 303       $dumpHint = $arg;
 304       next;
 305     }
 306
 307     if ($requestEvents == 1) {
 308       $requestEvents = 2;
 309       @show_events = split(/,/, $arg);
 310       next;
 311     }
 312
 313     if ($switchInstr == 1) {
 314       $switchInstr = 2;
 315       if ($arg eq "on") {
 316           $switchInstrMode = "on";
 317       }
 318       elsif ($arg eq "off") {
 319           $switchInstrMode = "off";
 320       }
 321       else {
 322           print "Error: need to specify 'on' or 'off' after '-i'.\n";
 323           shortHelp;
 324       }
 325       next;
 326     }
 327   }
 328
 329   if (defined $cmd{$arg}) { $spids{$arg} = 1; next; }
 330   $nameFound = 0;
 331   foreach $p (@pids) {
 332     if ($cmd{$p} =~ /$arg$/) {
 333       $nameFound = 1;
 334       $spids{$p} = 1;
 335     }
 336   }
 337   if ($nameFound) { next; }
 338
 339   print "Error: Callgrind task with PID/name '$arg' not detected.\n";
 340   shortHelp;
 341 }
 342
 343
 344 if ($switchInstr == 1) {
 345   print "Error: need to specify 'on' or 'off' after '-i'.\n";
 346   shortHelp;
 347 }
 348
 349 if (scalar @pids == 0) {
 350   print "No active callgrind runs detected.\n";
 351   exit;
 352 }
 353
 354 @spids = keys %spids;
 355 if (scalar @spids >0) { @pids = @spids; }
 356
 357 $vgdbCommand = "";
 358 $waitForAnswer = 0;
 359 if ($requestDump) {
 360   $vgdbCommand = "dump";
 361   if ($dumpHint ne "") { $vgdbCommand .= " ".$dumpHint; }
 362 }
 363 if ($requestZero) { $vgdbCommand = "zero"; }
 364 if ($requestKill) { $vgdbCommand = "v.kill"; }
 365 if ($switchInstr) { $vgdbCommand = "instrumentation ".$switchInstrMode; }
 366 if ($printStatus || $printBacktrace || $requestEvents) {
 367   $vgdbCommand = "status internal";
 368   $waitForAnswer = 1;
 369 }
 370
 371 foreach $pid (@pids) {
 372   $pidstr = "PID $pid: ";
 373   if ($pid >0) { print $pidstr.$cmdline{$pid}; }
 374
 375   if ($vgdbCommand eq "") {
 376       print "\n";
 377       next;
 378   }
 379   if ($verbose>0) {
 380       print " [requesting '$vgdbCommand']\n";
 381   } else {
 382       print "\n";
 383   }
 384   open RESULT, $vgdb_exe . " $vgdbPrefixOption --pid=$pid $vgdbCommand|";
 385
 386   @tids = ();
 387   $ctid = 0;
 388   %fcount = ();
 389   %func = ();
 390   %calls = ();
 391   %events = ();
 392   @events = ();
 393   @threads = ();
 394   %totals = ();
 395
 396   $exec_bbs = 0;
 397   $dist_bbs = 0;
 398   $exec_calls = 0;
 399   $dist_calls = 0;
 400   $dist_ctxs = 0;
 401   $dist_funcs = 0;
 402   $threads = "";
 403   $events = "";
 404
 405   while(<RESULT>) {
 406     if (/function-(\d+)-(\d+): (.+)$/) {
 407       if ($ctid != $1) {
 408         $ctid = $1;
 409         push(@tids, $ctid);
 410         $fcount{$ctid} = 0;
 411       }
 412       $fcount{$ctid}++;
 413       $func{$ctid,$fcount{$ctid}} = $3;
 414     }
 415     elsif (/calls-(\d+)-(\d+): (.+)$/) {
 416       if ($ctid != $1) { next; }
 417       $calls{$ctid,$fcount{$ctid}} = $3;
 418     }
 419     elsif (/events-(\d+)-(\d+): (.+)$/) {
 420       if ($ctid != $1) { next; }
 421       $events{$ctid,$fcount{$ctid}} = line_to_CC($3);
 422     }
 423     elsif (/events-(\d+): (.+)$/) {
 424       if (scalar @events == 0) { next; }
 425       $totals{$1} = line_to_CC($2);
 426     }
 427     elsif (/executed-bbs: (\d+)/) { $exec_bbs = $1; }
 428     elsif (/distinct-bbs: (\d+)/) { $dist_bbs = $1; }
 429     elsif (/executed-calls: (\d+)/) { $exec_calls = $1; }
 430     elsif (/distinct-calls: (\d+)/) { $dist_calls = $1; }
 431     elsif (/distinct-functions: (\d+)/) { $dist_funcs = $1; }
 432     elsif (/distinct-contexts: (\d+)/) { $dist_ctxs = $1; }
 433     elsif (/events: (.+)$/) { $events = $1; prepareEvents; }
 434     elsif (/threads: (.+)$/) { $threads = $1; @threads = split " ", $threads; }
 435     elsif (/instrumentation: (\w+)$/) { $instrumentation = $1; }
 436   }
 437
 438   #if ($? ne "0") { print " Got Error $?\n"; }
 439   if (!$waitForAnswer) { print "  OK.\n"; next; }
 440
 441   if ($instrumentation eq "off") {
 442     print "  No information available as instrumentation is switched off.\n\n";
 443     exit;
 444   }
 445
 446   if ($printStatus) {
 447     if ($requestEvents <1) {
 448       print "  Number of running threads: " .($#threads+1). ", thread IDs: $threads\n";
 449       print "  Events collected: $events\n";
 450     }
 451
 452     print "  Functions: ".commify($dist_funcs);
 453     print " (executed ".commify($exec_calls);
 454     print ", contexts ".commify($dist_ctxs).")\n";
 455
 456     print "  Basic blocks: ".commify($dist_bbs);
 457     print " (executed ".commify($exec_bbs);
 458     print ", call sites ".commify($dist_calls).")\n";
 459   }
 460
 461   if ($requestEvents >0) {
 462     $totals_width = compute_CC_col_widths(values %totals);
 463     print "\n  Totals:";
 464     print_events($totals_width);
 465     print("\n");
 466     foreach $tid (@tids) {
 467       print "   Th".substr("  ".$tid,-2)."  ";
 468       print_CC($totals{$tid}, $totals_width);
 469       print("\n");
 470     }
 471   }
 472
 473   if ($printBacktrace) {
 474
 475     if ($requestEvents >0) {
 476       $totals_width = compute_CC_col_widths(values %events);
 477     }
 478
 479     foreach $tid (@tids) {
 480       print "\n  Frame: ";
 481       if ($requestEvents >0) {
 482         print_events($totals_width);
 483       }
 484       print "Backtrace for Thread $tid\n";
 485
 486       $i = $fcount{$tid};
 487       $c = 0;
 488       while($i>0 && $c<100) {
 489         $fc = substr(" $c",-2);
 490         print "   [$fc]  ";
 491         if ($requestEvents >0) {
 492           print_CC($events{$tid,$i-1}, $totals_width);
 493         }
 494         print $func{$tid,$i};
 495         if ($i > 1) {
 496           print " (".$calls{$tid,$i-1}." x)";
 497         }
 498         print "\n";
 499         $i--;
 500         $c++;
 501       }
 502       print "\n";
 503     }
 504   }
 505   print "\n";
 506 }
 507