callgrind/callgrind_control.in

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