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